# HG changeset patch # User cvs # Date 1186989349 -7200 # Node ID a145efe767794446138c6d650bcafa01fb68b5ea # Parent a0ec055d74dd08a305fa950af21e729d98807aa3 Import from CVS: tag r20-1b3 diff -r a0ec055d74dd -r a145efe76779 CHANGES-beta --- a/CHANGES-beta Mon Aug 13 09:15:13 2007 +0200 +++ b/CHANGES-beta Mon Aug 13 09:15:49 2007 +0200 @@ -1,4 +1,20 @@ -*- indented-text -*- +to 20.1 beta3 +-- Customized edit-faces Courtesy of Jens Lautenbacher +-- W3-3.0.62 +-- AUCTeX-9.7k +-- mic-paren.el-1.3 Courtesy of Mikael Sjödin +-- hm--html-menus-5.3 +-- custom-1.46 +-- site-load.el preconfigured to work with DOC string generation +-- regex.c MULE bugfix Courtesy of David Moore +-- python-mode.el-2.90 +-- balloon-help-1.04 +-- xrdb-mode.el-1.21 +-- itimer.el-1.01 Courtesy of Kyle Jones +-- Miscellaneous bug fixes. +-- Dynamic computation of PURESIZE during build + to 20.1 beta2 -- First cut at MS Windows NT support Courtesy of David Hobley -- itimer.el-1.01 Courtesy of Kyle Jones @@ -13,7 +29,8 @@ -- hyperbole-4.021 Courtesy of Bob Weiner -- Restoration of reportmail.el Courtesy of jwz -- Restoration of passwd.el Courtesy of jwz --- AUC TeX-9.7i Courtesy of Per Abrahamsen +-- AUC TeX-9.7i Courtesy of Per Abrahamsen (Contributed code integrated + courtesy of Soren Dayton) -- viper-2.93 Courtesy of Michael Kifer -- ediff-2.64 Courtesy of Michael Kifer -- edmacro.el-3.05 diff -r a0ec055d74dd -r a145efe76779 ChangeLog --- a/ChangeLog Mon Aug 13 09:15:13 2007 +0200 +++ b/ChangeLog Mon Aug 13 09:15:49 2007 +0200 @@ -1,3 +1,10 @@ +Wed Feb 26 22:12:12 1997 Steven L Baur + + * Makefile.in (top_distclean): Reset src/PURESIZE.h for + distribution. + + * XEmacs 20.1-b3 is released. + Sun Feb 23 17:10:09 1997 Steven L Baur * XEmacs 20.1-b2 is released. @@ -6,6 +13,23 @@ * XEmacs 19-15-b'95 is released. +Fri Feb 21 22:29:51 1997 Martin Buchholz + + * etc/toolbar/workshop-cap-up.xpm: Moved caption up one pixel. + + * lwlib/xlwscrollbar.c : Fix many scrollbar bugs: + - "knob" renamed to "slider" + - leftmost pixel wasn't sensitive to button clicks, while righmost + pixel was. + - many glitches fixed if Emacs*XlwScrollBar.ArrowPosition:same: + - goobers on top of up-arrow removed. + - up-arrow would not always be redrawn when necessary + - slider drag would be `off' by size of up-arrow + - horizontal and vertical scrollbars didn't use exactly the same + dimensions. + - slider was never drawn if XlwScrollBar.shadowThickness was 0. + - Now up- and down-arrows actually work near beginning/end of buffer! + Thu Feb 20 12:40:57 1997 Jan Vroonhof * configure.in (with_xauth): Attempted correction of test for diff -r a0ec055d74dd -r a145efe76779 Makefile.in --- a/Makefile.in Mon Aug 13 09:15:13 2007 +0200 +++ b/Makefile.in Mon Aug 13 09:15:49 2007 +0200 @@ -489,7 +489,9 @@ top_distclean=\ rm -f config.status config-tmp-* build-install ; \ rm -f Makefile ${SUBDIR_MAKEFILES}; \ - (cd lock && rm -f *) + (cd lock && rm -f *) ; \ + echo "/* This file is generated by XEmacs, DO NOT MODIFY!!! */" > src/PURESIZE.h; \ + echo "# define PURESIZE 1350000" >> src/PURESIZE.h distclean: FRC.distclean (cd src && $(MAKE) $(MFLAGS) distclean) diff -r a0ec055d74dd -r a145efe76779 etc/Emacs.ad --- a/etc/Emacs.ad Mon Aug 13 09:15:13 2007 +0200 +++ b/etc/Emacs.ad Mon Aug 13 09:15:49 2007 +0200 @@ -76,13 +76,13 @@ *XmScrollBar*Background: Gray75 ! -! The Lucid Scrollbar supports two added resources, KnobStyle is either +! The Lucid Scrollbar supports two added resources, SliderStyle is either ! "plain" (default) or "dimple". Dimple puts a small dimple in the middle -! of the knob that depresses when the knob is clicked on. ArrowPosition is +! of the slider that depresses when the slider is clicked on. ArrowPosition is ! either "opposite" (default) or "same". Opposite puts the arrows at opposite ! of the scrollbar, same puts both arrows at the same end, like the Amiga. ! -! Emacs*XlwScrollBar.KnobStyle: dimple +! Emacs*XlwScrollBar.SliderStyle: dimple ! Emacs*XlwScrollBar.ArrowPosition: opposite diff -r a0ec055d74dd -r a145efe76779 etc/sample.Xdefaults --- a/etc/sample.Xdefaults Mon Aug 13 09:15:13 2007 +0200 +++ b/etc/sample.Xdefaults Mon Aug 13 09:15:49 2007 +0200 @@ -75,13 +75,13 @@ Emacs*XmScrollBar.Background: Gray75 ! -! The Lucid Scrollbar supports two added resources, KnobStyle is either +! The Lucid Scrollbar supports two added resources, SliderStyle is either ! "plain" (default) or "dimple". Dimple puts a small dimple in the middle -! of the knob that depresses when the knob is clicked on. ArrowPosition is +! of the slider that depresses when the slider is clicked on. ArrowPosition is ! either "opposite" (default) or "same". Opposite puts the arrows at opposite ! of the scrollbar, same puts both arrows at the same end, like the Amiga. ! -! Emacs*XlwScrollBar.KnobStyle: dimple +! Emacs*XlwScrollBar.SliderStyle: dimple ! Emacs*XlwScrollBar.ArrowPosition: opposite diff -r a0ec055d74dd -r a145efe76779 etc/sample.emacs --- a/etc/sample.emacs Mon Aug 13 09:15:13 2007 +0200 +++ b/etc/sample.emacs Mon Aug 13 09:15:49 2007 +0200 @@ -288,7 +288,7 @@ (t nil)))) (cond (bg (let ((def (color-name (face-background 'default))) - (faces (list-faces))) + (faces (face-list))) (while faces (let ((obg (face-background (car faces)))) (if (and obg (equal def (color-name obg))) @@ -368,7 +368,9 @@ ;; constructed using the environment variables USER and DOMAINNAME ;; (e.g. turner@lanl.gov), if set. -(if (and running-xemacs (< emacs-major-version 20) (>= emacs-minor-version 15)) +(if (and running-xemacs + (or (and (= emacs-major-version 20) (>= emacs-minor-version 1)) + (and (= emacs-major-version 19) (>= emacs-minor-version 15)))) (progn (message "Loading and configuring bundled packages... efs") (require 'efs-auto) @@ -380,22 +382,20 @@ (getenv "DOMAINNAME")) (setq efs-generate-anonymous-password (concat (getenv "USER")"@"(getenv "DOMAINNAME"))))) - (setq efs-auto-save 1) - )) -(if (and running-xemacs (< emacs-major-version 20) (< emacs-minor-version 15)) - (progn - (message "Loading and configuring bundled packages... ange-ftp") - (require 'ange-ftp) - (if (getenv "USER") - (setq ange-ftp-default-user (getenv "USER"))) - (if (getenv "EMAIL_ADDRESS") - (setq ange-ftp-generate-anonymous-password (getenv "EMAIL_ADDRESS")) - (if (and (getenv "USER") - (getenv "DOMAINNAME")) - (setq ange-ftp-generate-anonymous-password - (concat (getenv "USER")"@"(getenv "DOMAINNAME"))))) - (setq ange-ftp-auto-save 1) - ) + (setq efs-auto-save 1)) + (progn + (message "Loading and configuring bundled packages... ange-ftp") + (require 'ange-ftp) + (if (getenv "USER") + (setq ange-ftp-default-user (getenv "USER"))) + (if (getenv "EMAIL_ADDRESS") + (setq ange-ftp-generate-anonymous-password (getenv "EMAIL_ADDRESS")) + (if (and (getenv "USER") + (getenv "DOMAINNAME")) + (setq ange-ftp-generate-anonymous-password + (concat (getenv "USER")"@"(getenv "DOMAINNAME"))))) + (setq ange-ftp-auto-save 1) + ) ) diff -r a0ec055d74dd -r a145efe76779 etc/toolbar/workshop-cap-up.xpm --- a/etc/toolbar/workshop-cap-up.xpm Mon Aug 13 09:15:13 2007 +0200 +++ b/etc/toolbar/workshop-cap-up.xpm Mon Aug 13 09:15:49 2007 +0200 @@ -33,7 +33,6 @@ " ..XXX ", " ", " ", -" ", " X X ", " X X X X XX X ", " X X X X X X XXX XX XXX ", @@ -41,4 +40,5 @@ " X X X XX X X X X X X X ", " X X X X X X X X X X X ", " X X X X XX X X XX XXX ", -" X "}; +" X ", +" "}; diff -r a0ec055d74dd -r a145efe76779 etc/toolbar/workshop-cap-xx.xpm --- a/etc/toolbar/workshop-cap-xx.xpm Mon Aug 13 09:15:13 2007 +0200 +++ b/etc/toolbar/workshop-cap-xx.xpm Mon Aug 13 09:15:49 2007 +0200 @@ -33,7 +33,6 @@ " ..XXX ", " ", " ", -" ", " X X ", " X X X X XX X ", " X X X X X X XXX XX XXX ", @@ -41,4 +40,5 @@ " X X X XX X X X X X X X ", " X X X X X X X X X X X ", " X X X X XX X X XX XXX ", -" X "}; +" X ", +" "}; diff -r a0ec055d74dd -r a145efe76779 etc/w3/stylesheet --- a/etc/w3/stylesheet Mon Aug 13 09:15:13 2007 +0200 +++ b/etc/w3/stylesheet Mon Aug 13 09:15:49 2007 +0200 @@ -206,6 +206,14 @@ insert-before: "[["; insert-after: "]]" } + +input:text, +input:integer, +input:float, +input:url, +input:text { insert-before: "[{"; insert-after: "}]"; } +select { insert-before: "[{"; insert-after: "}]"; } + } // @media tty diff -r a0ec055d74dd -r a145efe76779 info/dir --- a/info/dir Mon Aug 13 09:15:13 2007 +0200 +++ b/info/dir Mon Aug 13 09:15:49 2007 +0200 @@ -46,7 +46,7 @@ Packages: -* AUC TeX:: Mode for editing TeX files. +* AUCTeX:: Mode for editing TeX files. * CC-MODE:: Mode for editing C, C++, and Objective-C code. * CL:: A Common Lisp compatibility package for Emacs-Lisp. * Custom:: Customization Library for Emacs diff -r a0ec055d74dd -r a145efe76779 lib-src/ChangeLog --- a/lib-src/ChangeLog Mon Aug 13 09:15:13 2007 +0200 +++ b/lib-src/ChangeLog Mon Aug 13 09:15:49 2007 +0200 @@ -1,3 +1,9 @@ +Wed Feb 26 18:17:59 1997 Steven L Baur + + * make-docfile.c (next_extra_elc): New function. + (main): Use it. Implementation of `-i' parameter to pass a list + of site-loaded lisp files. + Wed Feb 19 18:24:49 1997 Steven L Baur * update-elc.sh: Added lisp/auctex. diff -r a0ec055d74dd -r a145efe76779 lib-src/make-docfile.c --- a/lib-src/make-docfile.c Mon Aug 13 09:15:13 2007 +0200 +++ b/lib-src/make-docfile.c Mon Aug 13 09:15:49 2007 +0200 @@ -33,6 +33,9 @@ Then comes F for a function or V for a variable. Then comes the function or variable name, terminated with a newline. Then comes the documentation for that function or variable. + + Added 19.15/20.1: `-i site-packages' allow installer to dump extra packages + without modifying Makefiles, etc. */ #define NO_SHORTNAMES /* Tell config not to load remap.h */ @@ -74,6 +77,7 @@ /* Stdio stream for output to the DOC file. */ static FILE *outfile; +static char *extra_elcs = NULL; enum { @@ -130,6 +134,41 @@ return result; } +static char * +next_extra_elc(char *extra_elcs) +{ + static FILE *fp = NULL; + static char line_buf[BUFSIZ]; + char *p = line_buf+1; + + if (!fp) { + if (!extra_elcs) { + return NULL; + } else if (!(fp = fopen(extra_elcs, "r"))) { + /* It is not an error if this file doesn't exist. */ + /*fatal("error opening site package file list", 0);*/ + return NULL; + } + fgets(line_buf, BUFSIZ, fp); + } + +again: + if (!fgets(line_buf, BUFSIZ, fp)) { + fclose(fp); + fp = NULL; + return NULL; + } + line_buf[0] = '\0'; + if (strlen(p) <= 2 || strlen(p) >= (BUFSIZ - 5)) { + /* reject too short or too long lines */ + goto again; + } + p[strlen(p) - 2] = '\0'; + strcat(p, ".elc"); + + return p; +} + int main (int argc, char **argv) @@ -175,6 +214,11 @@ i += 2; } + if (argc > (i + 1) && !strcmp(argv[i], "-i")) { + extra_elcs = argv[i + 1]; + i += 2; + } + if (outfile == 0) fatal ("No output file specified", ""); @@ -190,6 +234,15 @@ /* err_count seems to be {mis,un}used */ err_count += scan_file (argv[i]); } + + if (extra_elcs) { + char *p; + + while ((p = next_extra_elc(extra_elcs)) != NULL) { + err_count += scan_file(p); + } + } + putc ('\n', outfile); #ifndef VMS exit (err_count > 0); diff -r a0ec055d74dd -r a145efe76779 lib-src/update-elc.sh --- a/lib-src/update-elc.sh Mon Aug 13 09:15:13 2007 +0200 +++ b/lib-src/update-elc.sh Mon Aug 13 09:15:49 2007 +0200 @@ -94,7 +94,7 @@ make_special oobr HYPB_ELC='' elc make_special eos -k # not stricly necessary... make_special ilisp elc -make_special auctex +make_special auctex some ignore_pattern='' for dir in $ignore_dirs ; do diff -r a0ec055d74dd -r a145efe76779 lisp/ChangeLog --- a/lisp/ChangeLog Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/ChangeLog Mon Aug 13 09:15:49 2007 +0200 @@ -1,3 +1,27 @@ +Wed Feb 26 18:09:56 1997 Andreas Jaeger + + * x11/x-menubar.el (default-menubar): `FAQ' should be `FAQ + (local)' in Help menu. + +Mon Feb 24 18:33:38 1997 Martin Buchholz + + * mule/mule-debug.el (describe-coding-system): Ported from + Mule to XEmacs. + + * mule/mule-x-init.el (x-use-halfwidth-roman-font): New + function: + "Maybe set charset registry of the 'ascii charset to ROMAN-REGISTRY. + + Do this only if: + - the current display is an X device + - the displayed width of FULLWIDTH-CHARSET is twice the displayed + width of the 'ascii charset, but only when using ROMAN-REGISTRY. + + Traditionally, Asian characters have been displayed so that they + occupy exactly twice the screen space of ASCII (`halfwidth') + characters. On many systems, e.g. Sun CDE systems, this can only be + achieved by using a national variant roman font to display ASCII." + Sun Feb 23 12:56:28 1997 Steven L Baur * edebug/edebug.el: Synch up with Emacs 19.34. diff -r a0ec055d74dd -r a145efe76779 lisp/auctex/ChangeLog --- a/lisp/auctex/ChangeLog Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/auctex/ChangeLog Mon Aug 13 09:15:49 2007 +0200 @@ -1,3 +1,29 @@ +Wed Feb 26 23:15:27 1997 Per Abrahamsen + + * Version 9.7k released. + +Wed Feb 26 23:14:43 1997 Per Abrahamsen + + * tex.el (TeX-submit-bug-report): Fix address (sunsite, not iesd!). + +Tue Feb 25 17:36:11 1997 Per Abrahamsen + + * Version 9.7j released. + +Fri Feb 21 09:29:20 1997 Per Abrahamsen + + * Makefile (some): New target. + Suggested by Steven L Baur . + +Thu Feb 20 11:30:50 1997 Per Abrahamsen + + * Version 9.7i released. + +Thu Feb 20 10:59:38 1997 Per Abrahamsen + + * tex.el: Removed autoloads that conflicts with `tex-mode.el'. + (TeX-lisp-directory): Default to data-directory. + Thu Feb 20 11:30:50 1997 Per Abrahamsen * Version 9.7i released. diff -r a0ec055d74dd -r a145efe76779 lisp/auctex/Makefile --- a/lisp/auctex/Makefile Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/auctex/Makefile Mon Aug 13 09:15:49 2007 +0200 @@ -1,7 +1,7 @@ # Makefile - for the AUC TeX distribution. # # Maintainer: Per Abrahamsen -# Version: 9.7i +# Version: 9.7k # # Edit the makefile, type `make', and follow the instructions. @@ -98,10 +98,9 @@ lisp: $(ELC) $(AUCSRC) $(STYLESRC) $(CONTRIB) -install: install-lisp +some: $(AUCELC) style/*.elc -tex.elc: tex.el - $(ELC) $(AUCSRC) $(STYLESRC) +install: install-lisp contrib: $(ELC) bib-cite.el @@ -109,7 +108,7 @@ # $(ELC) tex-jp.el # Doesn't compile without MULE # $(ELC) hilit-LaTeX.el # Doesn't compile without X -install-lisp: tex.elc +install-lisp: some if [ ! -d $(lispdir) ]; then mkdir $(lispdir); else true; fi ; if [ -f $(lispdir)/tex-site.el ]; \ then \ diff -r a0ec055d74dd -r a145efe76779 lisp/auctex/auc-old.el --- a/lisp/auctex/auc-old.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/auctex/auc-old.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,7 +1,7 @@ ;;; auc-old.el - Compatibility with AUC TeX 6.* ;; ;; Maintainer: Per Abrahamsen -;; Version: 9.7i +;; Version: 9.7k ;; ;; Copyright (C) 1991 Kresten Krab Thorup ;; Copyright (C) 1993 Per Abrahamsen diff -r a0ec055d74dd -r a145efe76779 lisp/auctex/latex.el --- a/lisp/auctex/latex.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/auctex/latex.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,7 +1,7 @@ ;;; latex.el --- Support for LaTeX documents. ;; ;; Maintainer: Per Abrahamsen -;; Version: 9.7i +;; Version: 9.7k ;; Keywords: wp ;; X-URL: http://sunsite.auc.dk/auctex diff -r a0ec055d74dd -r a145efe76779 lisp/auctex/tex-buf.el --- a/lisp/auctex/tex-buf.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/auctex/tex-buf.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,7 +1,7 @@ ;;; tex-buf.el - External commands for AUC TeX. ;; ;; Maintainer: Per Abrahamsen -;; Version: 9.7i +;; Version: 9.7k ;; Copyright (C) 1991 Kresten Krab Thorup ;; Copyright (C) 1993, 1996 Per Abrahamsen diff -r a0ec055d74dd -r a145efe76779 lisp/auctex/tex-info.el --- a/lisp/auctex/tex-info.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/auctex/tex-info.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,7 +1,7 @@ ;;; tex-info.el - Support for editing TeXinfo source. ;; ;; Maintainer: Per Abrahamsen -;; Version: 9.7i +;; Version: 9.7k ;; Copyright (C) 1993, 1994, 1997 Per Abrahamsen ;; diff -r a0ec055d74dd -r a145efe76779 lisp/auctex/tex.el --- a/lisp/auctex/tex.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/auctex/tex.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,7 +1,7 @@ ;;; tex.el --- Support for TeX documents. ;; Maintainer: Per Abrahamsen -;; Version: 9.7i +;; Version: 9.7k ;; Keywords: wp ;; X-URL: http://sunsite.auc.dk/auctex @@ -486,10 +486,10 @@ ;; These two variables are automatically updated with "make dist", so ;; be careful before changing anything. -(defconst AUC-TeX-version "9.7i" +(defconst AUC-TeX-version "9.7k" "AUC TeX version number") -(defconst AUC-TeX-date "Thu Feb 20 11:30:55 MET 1997" +(defconst AUC-TeX-date "Wed Feb 26 23:15:31 MET 1997" "AUC TeX release date") ;;; Buffer @@ -2594,7 +2594,7 @@ (interactive) (require 'reporter) (reporter-submit-bug-report - "auc-tex@iesd.auc.dk" + "auc-tex@sunsite.auc.dk" (concat "AUC TeX " AUC-TeX-version) (list 'window-system 'LaTeX-version diff -r a0ec055d74dd -r a145efe76779 lisp/comint/shell.el --- a/lisp/comint/shell.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/comint/shell.el Mon Aug 13 09:15:49 2007 +0200 @@ -250,13 +250,53 @@ (defvar shell-mode-hook nil "*Hook for customising Shell mode.") + +;; font-locking +(defvar shell-prompt-face 'shell-prompt-face + "Face for shell prompts.") +(defvar shell-option-face 'shell-option-face + "Face for command line options.") +(defvar shell-output-face 'shell-output-face + "Face for generic shell output.") +(defvar shell-output-2-face 'shell-output-2-face + "Face for grep-like output.") +(defvar shell-output-3-face 'shell-output-3-face + "Face for [N] output where N is a number.") + +(make-face shell-prompt-face) +(make-face shell-option-face) +(make-face shell-output-face) +(make-face shell-output-2-face) +(make-face shell-output-3-face) + +(defun shell-font-lock-mode-hook () + (or (face-differs-from-default-p shell-prompt-face) + (copy-face 'font-lock-keyword-face shell-prompt-face)) + (or (face-differs-from-default-p shell-option-face) + (copy-face 'font-lock-comment-face shell-option-face)) + (or (face-differs-from-default-p shell-output-face) + (copy-face 'italic shell-output-face)) + (or (face-differs-from-default-p shell-output-2-face) + (copy-face 'font-lock-string-face shell-output-2-face)) + (or (face-differs-from-default-p shell-output-3-face) + (copy-face 'font-lock-string-face shell-output-3-face)) + ;; we only need to do this once + (remove-hook 'font-lock-mode-hook 'shell-font-lock-mode-hook)) +(add-hook 'font-lock-mode-hook 'shell-font-lock-mode-hook) + +(defvar shell-prompt-pattern-for-font-lock shell-prompt-pattern + "Pattern to use to font-lock the prompt. +Defaults to `shell-prompt-pattern'.") + (defvar shell-font-lock-keywords - (list (cons shell-prompt-pattern 'font-lock-keyword-face) - '("[ \t]\\([+-][^ \t\n]+\\)" 1 font-lock-comment-face) - '("^[^ \t\n]+:.*" . font-lock-string-face) - '("^\\[[1-9][0-9]*\\]" . font-lock-string-face)) + (list (cons 'shell-prompt-pattern-for-font-lock shell-prompt-face) + '("[ \t]\\([+-][^ \t\n>]+\\)" 1 shell-option-face) + '("^[^ \t\n]+:.*" . shell-output-2-face) + '("^\\[[1-9][0-9]*\\]" . shell-output-3-face) + '("^[^\n]+.*$" . shell-output-face)) "Additional expressions to highlight in Shell mode.") (put 'shell-mode 'font-lock-defaults '(shell-font-lock-keywords t)) + ;;; Basic Procedures ;;; =========================================================================== diff -r a0ec055d74dd -r a145efe76779 lisp/custom/ChangeLog --- a/lisp/custom/ChangeLog Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/custom/ChangeLog Mon Aug 13 09:15:49 2007 +0200 @@ -1,3 +1,33 @@ +Wed Feb 26 22:17:38 1997 Per Abrahamsen + + * Version 1.46 released. + +Wed Feb 26 12:27:21 1997 Per Abrahamsen + + * custom.el (emacs): Moved to custom-edit.el. + (customize): Ditto. + * custom-edit.el: Added customization groups for all finder + keywords. + (customize): Add to the appropriate groups. + * widget-edit.el (widgets): Ditto. + * custom.texi (Usage for Package Authors): Documented it. + + * widget-edit.el (widget-push-button-value-create): Use + `device-on-window-system-p' instead of `device-type'. + + * Version 1.45 released. + +Wed Feb 26 12:26:30 1997 Per Abrahamsen + + * widget-edit.el (widget-push-button-value-create): Check that + (device-type) is x. + Reported by "Tomasz J. Cholewo" . + +Sun Feb 23 21:48:43 1997 Per Abrahamsen + + * custom-edit.el (customize-face): By default, customize all + faces. + Thu Feb 20 11:55:45 1997 Per Abrahamsen * Version 1.44 released. diff -r a0ec055d74dd -r a145efe76779 lisp/custom/custom-edit.el --- a/lisp/custom/custom-edit.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/custom/custom-edit.el Mon Aug 13 09:15:49 2007 +0200 @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen ;; Keywords: help, faces -;; Version: 1.44 +;; Version: 1.46 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;;; Commentary: @@ -22,6 +22,189 @@ :custom-set :custom-save :custom-reset-current :custom-reset-saved :custom-reset-factory) +;;; Customization Groups. + +(defgroup emacs nil + "Customization of the One True Editor." + :link '(custom-manual "(emacs)Top")) + +;; Most of these groups are stolen from `finder.el', +(defgroup editing nil + "Basic text editing facilities." + :group 'emacs) + +(defgroup abbrev nil + "Abbreviation handling, typing shortcuts, macros." + :tag "Abbreviations" + :group 'editing) + +(defgroup matching nil + "Various sorts of searching and matching." + :group 'editing) + +(defgroup emulations nil + "Emulations of other editors." + :group 'editing) + +(defgroup mouse nil + "Mouse support." + :group 'editing) + +(defgroup outlines nil + "Support for hierarchical outlining." + :group 'editing) + +(defgroup external nil + "Interfacing to external utilities." + :group 'emacs) + +(defgroup bib nil + "Code related to the `bib' bibliography processor." + :tag "Bibliography" + :group 'external) + +(defgroup processes nil + "Process, subshell, compilation, and job control support." + :group 'external + :group 'development) + +(defgroup programming nil + "Support for programming in other languages." + :group 'emacs) + +(defgroup languages nil + "Specialized modes for editing programming languages." + :group 'programming) + +(defgroup lisp nil + "Lisp support, including Emacs Lisp." + :group 'languages + :group 'development) + +(defgroup c nil + "Support for the C language and related languages." + :group 'languages) + +(defgroup tools nil + "Programming tools." + :group 'programming) + +(defgroup oop nil + "Support for object-oriented programming." + :group 'programming) + +(defgroup applications nil + "Applications written in Emacs." + :group 'emacs) + +(defgroup calendar nil + "Calendar and time management support." + :group 'applications) + +(defgroup mail nil + "Modes for electronic-mail handling." + :group 'applications) + +(defgroup news nil + "Support for netnews reading and posting." + :group 'applications) + +(defgroup games nil + "Games, jokes and amusements." + :group 'applications) + +(defgroup development nil + "Support for further development of Emacs." + :group 'emacs) + +(defgroup docs nil + "Support for Emacs documentation." + :group 'development) + +(defgroup extensions nil + "Emacs Lisp language extensions." + :group 'development) + +(defgroup internal nil + "Code for Emacs internals, build process, defaults." + :group 'development) + +(defgroup maint nil + "Maintenance aids for the Emacs development group." + :tag "Maintenance" + :group 'development) + +(defgroup environment nil + "Fitting Emacs with its environment." + :group 'emacs) + +(defgroup comm nil + "Communications, networking, remote access to files." + :tag "Communication" + :group 'environment) + +(defgroup hardware nil + "Support for interfacing with exotic hardware." + :group 'environment) + +(defgroup terminals nil + "Support for terminal types." + :group 'environment) + +(defgroup unix nil + "Front-ends/assistants for, or emulators of, UNIX features." + :group 'environment) + +(defgroup vms nil + "Support code for vms." + :group 'environment) + +(defgroup i18n nil + "Internationalization and alternate character-set support." + :group 'environment + :group 'editing) + +(defgroup frames nil + "Support for Emacs frames and window systems." + :group 'environment) + +(defgroup data nil + "Support editing files of data." + :group 'emacs) + +(defgroup wp nil + "Word processing." + :group 'emacs) + +(defgroup tex nil + "Code related to the TeX formatter." + :group 'wp) + +(defgroup faces nil + "Support for multiple fonts." + :group 'emacs) + +(defgroup hypermedia nil + "Support for links between text or other media types." + :group 'emacs) + +(defgroup help nil + "Support for on-line help systems." + :group 'emacs) + +(defgroup local nil + "Code local to your site." + :group 'emacs) + +(defgroup customize '((widgets custom-group)) + "Customization of the Customization support." + :link '(custom-manual "(custom)Top") + :link '(url-link :tag "Development Page" + "http://www.dina.kvl.dk/~abraham/custom/") + :prefix "custom-" + :group 'help + :group 'faces) + ;;; Utilities. (defun custom-quote (sexp) @@ -261,15 +444,24 @@ (custom-buffer-create (list (list symbol 'custom-variable)))) ;;;###autoload -(defun customize-face (symbol) - "Customize FACE." - (interactive (list (completing-read "Customize face: " +(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) " obarray 'custom-facep))) - (if (stringp symbol) - (setq symbol (intern symbol))) - (unless (symbolp symbol) - (error "Should be a symbol %S" symbol)) - (custom-buffer-create (list (list symbol 'custom-face)))) + (if (or (null symbol) (and (stringp symbol) (zerop (length symbol)))) + (let ((found nil)) + (message "Looking for faces...") + (mapcar (lambda (symbol) + (setq found (cons (list symbol 'custom-face) found))) + (face-list)) + (message "Creating customization buffer...") + (custom-buffer-create found)) + (if (stringp symbol) + (setq symbol (intern symbol))) + (unless (symbolp symbol) + (error "Should be a symbol %S" symbol)) + (custom-buffer-create (list (list symbol 'custom-face))))) ;;;###autoload (defun customize-customized () diff -r a0ec055d74dd -r a145efe76779 lisp/custom/custom-xmas.el --- a/lisp/custom/custom-xmas.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/custom/custom-xmas.el Mon Aug 13 09:15:49 2007 +0200 @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen ;; Keywords: help, faces -;; Version: 1.44 +;; Version: 1.46 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;;; Commentary: @@ -27,10 +27,7 @@ (color-instance-rgb-components (make-color-instance color)))) ;; Overwrite Emacs definition. -(defun custom-facep (face) - "Face symbol or object." - (or (facep face) - (find-face face))) +(defalias 'custom-facep 'find-face) ;; Support for special XEmacs font attributes. (autoload 'font-create-object "font" nil) diff -r a0ec055d74dd -r a145efe76779 lisp/custom/custom.el --- a/lisp/custom/custom.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/custom/custom.el Mon Aug 13 09:15:49 2007 +0200 @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen ;; Keywords: help, faces -;; Version: 1.44 +;; Version: 1.46 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;;; Commentary: @@ -494,18 +494,6 @@ ;;; Meta Customization -(defgroup emacs nil - "Customization of the One True Editor." - :link '(custom-manual "(emacs)Top")) - -(defgroup customize '((widgets custom-group)) - "Customization of the Customization support." - :link '(custom-manual "(custom)Top") - :link '(url-link :tag "Development Page" - "http://www.dina.kvl.dk/~abraham/custom/") - :prefix "custom-" - :group 'emacs) - (defcustom custom-define-hook nil "Hook called after defining each customize option." :group 'customize diff -r a0ec055d74dd -r a145efe76779 lisp/custom/widget-browse.el --- a/lisp/custom/widget-browse.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/custom/widget-browse.el Mon Aug 13 09:15:49 2007 +0200 @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen ;; Keywords: extensions -;; Version: 1.44 +;; Version: 1.46 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;;; Commentary: diff -r a0ec055d74dd -r a145efe76779 lisp/custom/widget-edit.el --- a/lisp/custom/widget-edit.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/custom/widget-edit.el Mon Aug 13 09:15:49 2007 +0200 @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen ;; Keywords: extensions -;; Version: 1.44 +;; Version: 1.46 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;;; Commentary: @@ -84,7 +84,10 @@ :link '(url-link :tag "Development Page" "http://www.dina.kvl.dk/~abraham/custom/") :prefix "widget-" - :group 'emacs) + :group 'help + :group 'extensions + :group 'faces + :group 'hypermedia) (defface widget-documentation-face '((((class color) (background dark)) @@ -1120,6 +1123,8 @@ (if (and (fboundp 'make-gui-button) (fboundp 'make-glyph) widget-push-button-gui + (fboundp 'device-on-window-system-p) + (device-on-window-system-p) (string-match "XEmacs" emacs-version)) (progn (unless gui diff -r a0ec055d74dd -r a145efe76779 lisp/custom/widget-example.el --- a/lisp/custom/widget-example.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/custom/widget-example.el Mon Aug 13 09:15:49 2007 +0200 @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen ;; Keywords: help, extensions, faces, hypermedia -;; Version: 1.44 +;; Version: 1.46 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ (require 'widget) diff -r a0ec055d74dd -r a145efe76779 lisp/custom/widget.el --- a/lisp/custom/widget.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/custom/widget.el Mon Aug 13 09:15:49 2007 +0200 @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen ;; Keywords: help, extensions, faces, hypermedia -;; Version: 1.44 +;; Version: 1.46 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;;; Commentary: diff -r a0ec055d74dd -r a145efe76779 lisp/ediff/ediff-init.el --- a/lisp/ediff/ediff-init.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/ediff/ediff-init.el Mon Aug 13 09:15:49 2007 +0200 @@ -1156,10 +1156,10 @@ ;;; In-line functions -(or (fboundp 'ediff-file-remote-p) ; user supplied his own function +(or (fboundp 'ediff-file-remote-p) ; user supplied his own function: use it (defun ediff-file-remote-p (file-name) - (car (cond ((featurep 'efs) (efs-ftp-path file-name)) - ((fboundp 'file-remote-p) (efs-ftp-path 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)))))) diff -r a0ec055d74dd -r a145efe76779 lisp/efs/ange-ftp.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/ange-ftp.el Mon Aug 13 09:15:49 2007 +0200 @@ -0,0 +1,39 @@ +;;; ange-ftp.el --- Stub for EFS-enabled XEmacs + +;; Copyright (C) 1997 by Steven L Baur + +;; Author: Steven L Baur +;; 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; 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: + +;; Compatibility module for users who still attempt to reference the +;; obsolete ange-ftp. + +;;; Code: + +(require 'efs-auto) +(warn "ange-ftp is obsolete, using efs-auto") + +(provide 'ange-ftp) + +;;; ange-ftp.el ends here diff -r a0ec055d74dd -r a145efe76779 lisp/hm--html-menus/ANNOUNCEMENT --- a/lisp/hm--html-menus/ANNOUNCEMENT Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/hm--html-menus/ANNOUNCEMENT Mon Aug 13 09:15:49 2007 +0200 @@ -1,9 +1,9 @@ Hello, -I've written a new version (5.2) of my html package for the XEmacs +I've written a new version (5.3) of my html package for the XEmacs and the GNU Emacs 19. The name of the package is: - hm--html-menus-5.2.tar.gz + hm--html-menus-5.3.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 @@ -25,7 +25,7 @@ - a lot of bug fixes Read the NEWS file to see news in detail... -You should find hm--html-menus-5.2.tar.gz on the following ftp server: +You should find hm--html-menus-5.3.tar.gz on the following ftp server: sunsite.unc.edu in /pub/Linux/apps/editors/emacs/ ftp.rrzn.uni-hannover.de in /pub/unix/editors/lemacs/contrib ftp.tnt.uni-hannover.de in /pub/editors/xemacs/contrib @@ -36,6 +36,10 @@ There is also 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 another html major mode, like the psgml-html +mode in the XEmacs 19.14. + NOTE: This version is not tested with the Emacs 19. One of the next releases in the near future will be a bug fix only release for the Emacs 19. So please report any bugs to muenkel@tnt.uni-hannover.de. diff -r a0ec055d74dd -r a145efe76779 lisp/hm--html-menus/NEWS --- a/lisp/hm--html-menus/NEWS Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/hm--html-menus/NEWS Mon Aug 13 09:15:49 2007 +0200 @@ -1,6 +1,31 @@ +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 + -- 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. @@ -22,7 +47,7 @@ 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 + -- 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' @@ -111,7 +136,7 @@ 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 + -- BUILDED the version 5.0 of the package -- 03.08.96: Applied a patch from Jerry G. DeLapp to `html-font-lock-keywords'. @@ -209,7 +234,7 @@ 01.03.96: Added the function `tmpl-insert-template-file'. 18.02.96: - -- BUILDED the version 4.16 of the package + -- BUILDED the version 4.16 of the package -- 17.02.96: Added the mailto link. 03.02.96: diff -r a0ec055d74dd -r a145efe76779 lisp/hm--html-menus/README --- a/lisp/hm--html-menus/README Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/hm--html-menus/README Mon Aug 13 09:15:49 2007 +0200 @@ -1,7 +1,10 @@ -This README file describes the emacs lisp package hm--html-menus-5.2. +This README file describes the emacs lisp package hm--html-menus-5.3. 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.14. 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 @@ -25,7 +28,7 @@ only UNIX ?) platforms. NOTE: The current release isn't tested with the Emacs 19 (5.0 is but -5.1 and 5.2 are not). One of the next releases in the near future :-) will be a +5.1 to 5.3 are not). One of the next releases in the near future :-) will be a bug fix only release for the Emacs 19. So please report any bugs to muenkel@tnt.uni-hannover.de to shorten the time until the Emacs 19 related bugs are fixed. @@ -50,14 +53,17 @@ adapt.el : provides functions to use this package with the GNU Emacs 19 hm--html.el : provides functions to write html pages; - some of these functions are similar to - functions of the html-mode.el; + 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 hteml 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 @@ -99,8 +105,8 @@ 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 directrory and -the system (site) configuration file in one of the load path directories -of your xemacs or GNU Emacs 19. +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). @@ -154,6 +160,11 @@ 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) + 3. 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 diff -r a0ec055d74dd -r a145efe76779 lisp/hm--html-menus/command-description.tmpl Binary file lisp/hm--html-menus/command-description.tmpl has changed diff -r a0ec055d74dd -r a145efe76779 lisp/hm--html-menus/frame.tmpl Binary file lisp/hm--html-menus/frame.tmpl has changed diff -r a0ec055d74dd -r a145efe76779 lisp/hm--html-menus/hm--html-configuration.el --- a/lisp/hm--html-menus/hm--html-configuration.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/hm--html-menus/hm--html-configuration.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,6 +1,6 @@ ;;; hm--html-configuration.el - Configurationfile for the html-mode ;;; -;;; $Id: hm--html-configuration.el,v 1.3 1997/02/24 01:13:26 steve Exp $ +;;; $Id: hm--html-configuration.el,v 1.4 1997/02/27 06:08:08 steve Exp $ ;;; ;;; Copyright (C) 1993 - 1997 Heiko Muenkel ;;; email: muenkel@tnt.uni-hannover.de @@ -616,6 +616,8 @@ (:hm--html-optional-attributes (size color))) ("map" (:hm--html-two-element-tag t) (:hm--html-required-attributes (name))) + ("style" (:hm--html-two-element-tag t)) + ("script" (:hm--html-two-element-tag t)) ) "An alist with tag names known by the `hm--html-mode'. CURRENTLY THIS LIST CONTAINS NOT ALL TAGS!!!!. diff -r a0ec055d74dd -r a145efe76779 lisp/hm--html-menus/hm--html-keys.el --- a/lisp/hm--html-menus/hm--html-keys.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/hm--html-menus/hm--html-keys.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,4 +1,4 @@ -;;; $Id: hm--html-keys.el,v 1.3 1997/02/24 01:13:27 steve Exp $ +;;; $Id: hm--html-keys.el,v 1.4 1997/02/27 06:08:09 steve Exp $ ;;; ;;; Copyright (C) 1995, 1996, 1997 Heiko Muenkel ;;; email: muenkel@tnt.uni-hannover.de @@ -57,7 +57,6 @@ (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-link) -; (define-key hm--html-noregion-anchor-map "\C-m" 'hm--html-add-mailto-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) @@ -86,8 +85,6 @@ "\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-link-to-region) -; (define-key hm--html-region-anchor-map -; "\C-m" 'hm--html-add-mailto-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 @@ -111,6 +108,7 @@ () (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) @@ -118,7 +116,10 @@ [(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 @@ -178,6 +179,8 @@ (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) @@ -196,21 +199,21 @@ (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-directory-list-to-region) + "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-d\C-t" 'html-add-description-title-and-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-formating-paragraph-map nil @@ -219,16 +222,24 @@ (if hm--html-noregion-formating-paragraph-map () (setq hm--html-noregion-formating-paragraph-map (make-sparse-keymap)) +; (define-key hm--html-noregion-formating-paragraph-map +; "o" 'hm--html-add-plaintext) (define-key hm--html-noregion-formating-paragraph-map - "o" 'hm--html-add-plaintext) - (define-key hm--html-noregion-formating-paragraph-map - "w" 'hm--html-add-preformated) + "p" 'hm--html-add-preformated) (define-key hm--html-noregion-formating-paragraph-map "b" 'hm--html-add-blockquote) (define-key hm--html-noregion-formating-paragraph-map - "l" 'hm--html-add-listing) + "C-b" 'hm--html-add-basefont) + (define-key hm--html-noregion-formating-paragraph-map + "f" 'hm--html-add-font) + (define-key hm--html-noregion-formating-paragraph-map + "c" 'hm--html-add-center) (define-key hm--html-noregion-formating-paragraph-map - "a" 'hm--html-add-abstract) + "C-c" 'hm--html-add-comment-to-region) +; (define-key hm--html-noregion-formating-paragraph-map +; "l" 'hm--html-add-listing) +; (define-key hm--html-noregion-formating-paragraph-map +; "a" 'hm--html-add-abstract) ) (defvar hm--html-region-formating-paragraph-map nil @@ -237,16 +248,24 @@ (if hm--html-region-formating-paragraph-map () (setq hm--html-region-formating-paragraph-map (make-sparse-keymap)) +; (define-key hm--html-region-formating-paragraph-map +; "o" 'hm--html-add-plaintext-to-region) (define-key hm--html-region-formating-paragraph-map - "o" 'hm--html-add-plaintext-to-region) - (define-key hm--html-region-formating-paragraph-map - "w" 'hm--html-add-preformated-to-region) + "p" 'hm--html-add-preformated-to-region) (define-key hm--html-region-formating-paragraph-map "b" 'hm--html-add-blockquote-to-region) (define-key hm--html-region-formating-paragraph-map - "l" 'hm--html-add-listing-to-region) + "C-b" 'hm--html-add-basefont-to-region) + (define-key hm--html-region-formating-paragraph-map + "f" 'hm--html-add-font-to-region) + (define-key hm--html-region-formating-paragraph-map + "c" 'hm--html-add-center-to-region) (define-key hm--html-region-formating-paragraph-map - "a" 'hm--html-add-abstract-to-region) + "C-c" 'hm--html-add-comment-to-region) +; (define-key hm--html-region-formating-paragraph-map +; "l" 'hm--html-add-listing-to-region) +; (define-key hm--html-region-formating-paragraph-map +; "a" 'hm--html-add-abstract-to-region) ) (defvar hm--html-noregion-formating-word-map nil @@ -315,11 +334,18 @@ (if hm--html-noregion-include-map () (setq hm--html-noregion-include-map (make-sparse-keymap)) - (define-key hm--html-noregion-include-map "t" 'hm--html-add-image-top) - (define-key hm--html-noregion-include-map "m" 'hm--html-add-image-middle) - (define-key hm--html-noregion-include-map "b" 'hm--html-add-image-bottom) + (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) + (define-key hm--html-noregion-include-map "p" 'hm--html-add-applet-parameter) ) (defvar hm--html-region-include-map nil @@ -328,6 +354,8 @@ (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 diff -r a0ec055d74dd -r a145efe76779 lisp/hm--html-menus/hm--html-menu.el --- a/lisp/hm--html-menus/hm--html-menu.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/hm--html-menus/hm--html-menu.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,6 +1,6 @@ ;;; hm--html-menu --- A menu for the hm--html-mode. ;;; -;;; $Id: hm--html-menu.el,v 1.3 1997/02/24 01:13:27 steve Exp $ +;;; $Id: hm--html-menu.el,v 1.4 1997/02/27 06:08:09 steve Exp $ ;;; ;;; Copyright (C) 1993 - 1997 Heiko Muenkel ;;; email: muenkel@tnt.uni-hannover.de @@ -133,16 +133,18 @@ ["Horizontal rule" hm--html-add-horizontal-rule t] ) ("Formating Paragraphs" - ["Without links" hm--html-add-plaintext t] - ["With links" hm--html-add-preformated t] +; ["Without links" hm--html-add-plaintext t] + ["Preformated" hm--html-add-preformated t] + ["Blockquote" hm--html-add-blockquote t] "----" ["Basefont..." hm--html-add-basefont t] ["Font..." hm--html-add-font t] - ["Blockquote" hm--html-add-blockquote t] - ["Listing" hm--html-add-listing t] - ["Abstract" hm--html-add-abstract t] + ["Center" hm--html-add-center t] + ["Style" hm--html-add-style t] "----" - ["Center" hm--html-add-center 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] @@ -155,7 +157,6 @@ "----" ["Underline" hm--html-add-underline t] ["Strikethru" hm--html-add-strikethru t] - ;; ["Render" hm--html-add-render t] "----" ; ["Emphasized" hm--html-add-emphasized t] ; ["Strong" hm--html-add-strong t] @@ -173,6 +174,7 @@ ) ;; 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] @@ -203,8 +205,8 @@ ; "----" ; ["Footnote" hm--html-add-footnote t] ; ["Margin" hm--html-add-margin t] - "----" - ["HTML Comment" hm--html-add-comment t] +; "----" +; ["HTML Comment" hm--html-add-comment t] ) ("Include" ["Top aligned image..." hm--html-add-image-top t] @@ -222,6 +224,7 @@ "----" ["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] @@ -282,8 +285,8 @@ ["Paragraph Container" hm--html-add-paragraph t] ) ("Formating Paragraphs" - ["Without links" hm--html-add-plaintext t] - ["With links" hm--html-add-preformated t] +; ["Without links" hm--html-add-plaintext t] + ["Preformated" hm--html-add-preformated t] ) ("Formatting Words" ["Bold" hm--html-add-bold t] @@ -353,15 +356,17 @@ ["Document division" hm--html-add-document-division-to-region t] ) ("Formatting Paragraphs" - ["Without links" hm--html-add-plaintext-to-region t] - ["With links" hm--html-add-preformated-to-region t] +; ["Without links" hm--html-add-plaintext-to-region t] + ["Preformated" hm--html-add-preformated-to-region t] + ["Blockquote" hm--html-add-blockquote-to-region t] "----" ["Font..." hm--html-add-font-to-region t] - ["Blockquote" hm--html-add-blockquote-to-region t] - ["Listing" hm--html-add-listing-to-region t] - ["Abstract" hm--html-add-abstract-to-region t] + ["Center" hm--html-add-center-to-region t] + ["Style" hm--html-add-style-to-region t] "----" - ["Center" hm--html-add-center-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] @@ -422,13 +427,14 @@ ; "----" ; ["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] +; "----" +; ["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]) @@ -457,8 +463,8 @@ ["Menu" hm--html-add-menu-to-region t] ) ("Formatting Paragraphs" - ["Without links" hm--html-add-plaintext-to-region t] - ["With links" hm--html-add-preformated-to-region t] +; ["Without links" hm--html-add-plaintext-to-region t] + ["Preformated" hm--html-add-preformated-to-region t] ) ("Formatting Words" ["Bold" hm--html-add-bold-to-region t] @@ -483,7 +489,6 @@ :active t :style radio :selected hm--html-expert] -; ["Marcs menu" hm--html-use-marcs-menu t] ) ["Reload config files" hm--html-load-config-files t] ["Templates (fixed dirs) ..." @@ -529,7 +534,7 @@ (if (and current-menubar (not (assoc menu-name current-menubar))) (progn (set-buffer-menubar (copy-sequence current-menubar)) - (add-menu nil menu-name (cdr hm--html-pulldown-menu))))) + (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) @@ -543,16 +548,6 @@ "The hm--html-minor-mode pulldown menu." (cons menu-name (cdr hm--html-pulldown-menu)))) -; (easy-menu-define hm--html-region-menu-map -; hm--html-region-mode-map -; "The hm--html-mode pulldown menu, if a region is active." -; (cons menu-name -; (cdr hm--html-pulldown-menu))) -; (if (and current-menubar (not (assoc "HTML" current-menubar))) -; (progn -; (set-buffer-menubar current-menubar) -; )) -; (add-menu nil "HTML" (cdr hm--html-pulldown-menu)) )) (if (adapt-emacs19p) @@ -584,60 +579,22 @@ (x-popup-menu nil hm--html-menu-region-novice-map)) -; (defun hm--html-emacs19-popup-menu (menu event) -; (let ((pos (posn-x-y (event-end event))) -; (window (posn-window (event-start event))) -; (answer)) -; (while menu -; (setq answer (x-popup-menu (list (list (car pos) (cdr pos)) -; window) -; menu)) -; (setq cmd (lookup-key menu (apply 'vector answer))) -; (setq menu nil) -; (and cmd -; (if (keymapp cmd) -; (setq menu cmd) -; (call-interactively cmd)))))) - -; (defun hm--html-popup-menu (event) -; "Pops the HTML- menu up, if no region is active." -; (interactive "@e") -; (if hm--html-expert -; (hm--html-emacs19-popup-menu hm--html-menu-noregion-expert-map -; event) -; (hm--html-emacs19-popup-menu hm--html-menu-noregion-novice-map -; event))) - -; (defun hm--html-popup-menu-region (event) -; "Pops the HTML- menu up, if a region is active." -; (interactive "@e") -; (if hm--html-expert -; (hm--html-emacs19-popup-menu hm--html-menu-region-expert-map -; event) -; (hm--html-emacs19-popup-menu hm--html-menu-region-novice-map -; event))) ) (defun hm--html-popup-menu (event) "Pops the HTML- menu up, if no region is active." (interactive "@e") -; (if hm--html-marc -; (popup-menu html-menu) (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-marc -; (popup-menu html-menu) (if hm--html-expert (popup-menu hm--html-menu-region-expert) (popup-menu hm--html-menu-region-novice))) -;) ) @@ -648,9 +605,6 @@ "Changes the HTML popup menu to the novice menu." (interactive) (setq hm--html-expert nil) -; (setq hm--html-marc nil) -; (define-key html-mode-map '(button3) 'hm--popup-html-menu) -; (define-key html-region-mode-map '(button3) 'hm--popup-html-menu) ) @@ -658,9 +612,6 @@ "Changes the HTML popup menu to the expert menu." (interactive) (setq hm--html-expert t) -; (setq hm--html-marc nil) -; (define-key html-mode-map '(button3) 'hm--popup-html-menu) -; (define-key html-region-mode-map '(button3) 'hm--popup-html-menu) ) ) @@ -706,45 +657,6 @@ ) ) -;(defun hm--html-use-marcs-menu () -; "Changes the HTML popup menu to Marc Andreessens menu." -; (interactive) -; (setq hm--html-marc t) -; ) - - -;(define-key html-mode-map '(button3) 'hm--popup-html-menu) -;(define-key html-region-mode-map '(button3) 'hm--popup-html-menu) - -;(add-hook 'html-mode-hook 'hm--install-html-menu) - - -;(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))) -; (sgml-xemacs-get-popup-value (append hm--html-popup-menu -; (list "--" "--" title "==") -; entries))) (defvar hm--html-use-psgml t "Set this to t, if functions from the psgml-mode should be used.") @@ -835,10 +747,6 @@ )) -;(defvar hm--html-menu-load-hook nil -; "*Hook variable to execute functions after loading the file hm--html-menu.") - - (run-hooks 'hm--html-menu-load-hook) diff -r a0ec055d74dd -r a145efe76779 lisp/hm--html-menus/hm--html-mode.el --- a/lisp/hm--html-menus/hm--html-mode.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/hm--html-menus/hm--html-mode.el Mon Aug 13 09:15:49 2007 +0200 @@ -2,7 +2,7 @@ ;;; ;;; Keywords: hypermedia languages help docs wp ;;; -;;; $Id: hm--html-mode.el,v 1.3 1997/02/24 01:13:27 steve Exp $ +;;; $Id: hm--html-mode.el,v 1.4 1997/02/27 06:08:09 steve Exp $ ;;; ;;; Copyright (C) 1996, 1997 Heiko Muenkel ;;; email: muenkel@tnt.uni-hannover.de @@ -53,6 +53,14 @@ ;;; (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. ;;; @@ -63,13 +71,19 @@ (require 'adapt) (require 'hm--date) (require 'hm--html) + (eval-when-compile (require 'hm--html-configuration)) + (hm--html-load-config-files) (require 'hm--html-indentation) +(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) -(require 'hm--html-keys) ;;; The package version @@ -77,7 +91,7 @@ (defconst hm--html-menus-package-name "hm--html-menus") -(defconst hm--html-menus-package-version "5.2") +(defconst hm--html-menus-package-version "5.3") ;;; Generate the help buffer faces @@ -132,6 +146,7 @@ (setq comment-start "") (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) @@ -204,10 +219,6 @@ ;;; hm--html-minor-mode - -(defvar hm--html-minor-mode nil - "Non-nil, if the `hm--html-minor-mode' is active.") - (make-variable-buffer-local 'hm--html-minor-mode) (add-minor-mode 'hm--html-minor-mode " HM-HTML" hm--html-minor-mode-map) diff -r a0ec055d74dd -r a145efe76779 lisp/hm--html-menus/hm--html.el --- a/lisp/hm--html-menus/hm--html.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/hm--html-menus/hm--html.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,4 +1,4 @@ -;;; $Id: hm--html.el,v 1.3 1997/02/24 01:13:28 steve Exp $ +;;; $Id: hm--html.el,v 1.4 1997/02/27 06:08:10 steve Exp $ ;;; ;;; Copyright (C) 1993 - 1997 Heiko Muenkel ;;; email: muenkel@tnt.uni-hannover.de @@ -88,7 +88,6 @@ (goto-char end) (eval (list function-insert-end-tag end-tag)) (goto-char start) -; (backward-char (+ (length end-tag) (- end start))) (eval (list function-insert-start-tag start-tag)) (if function-insert-middle-tag (eval (list function-insert-middle-tag middle-tag))) @@ -101,7 +100,6 @@ (let ((start (point))) (insert tag) (hm--html-indent-region start (point)))) -; (html-maybe-deemphasize-region start (- (point) 1)))) (defun hm--html-insert-end-tag (tag) @@ -110,7 +108,6 @@ (let ((start (point))) (insert tag) (hm--html-indent-region start (point)))) -; (html-maybe-deemphasize-region start (- (point) 1)))) (defun hm--html-insert-start-tag-with-newline (tag) @@ -280,18 +277,18 @@ (setq head-end-point (when (re-search-forward "\\(")))) + (point))) + (goto-char point) + (hm--html-search-place-for-element-in-head head-end-point) + (hm--html-add-tags 'hm--html-insert-start-tag + (concat ""))))) ;;; Functions which include something in HTML- documents @@ -560,7 +557,6 @@ (if (string= file "") (error "ERROR: No filename specified !") (insert "")))) -; (html-maybe-deemphasize-region (1+ start) (1- (point)))))) (defun hm--html-add-server-side-include-command-with-isindex-parameter @@ -589,32 +585,6 @@ (if (= ?| (string-to-char command)) (insert "") (insert ""))))) -; (html-maybe-deemphasize-region (1+ start) (1- (point))))))) - - -;(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 '?': "))) -; (let ((start (point))) -; (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 "") -; (insert "")) -; (if (= ?? (string-to-char parameter)) -; (insert "") -; (insert ""))) -; (html-maybe-deemphasize-region (1+ start) (1- (point))))))) - ;;; Functions, which adds tags of the form ... @@ -922,24 +892,6 @@ "")) -(defun hm--html-add-plaintext () - "Adds the HTML tags for plaintext." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "" - 'hm--html-insert-end-tag-with-newline - "")) - - -(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 - "" - 'hm--html-insert-end-tag-with-newline - "")) - - (defun hm--html-add-blockquote () "Adds the HTML tags for blockquote." (interactive) @@ -957,24 +909,39 @@ 'hm--html-insert-end-tag-with-newline "")) -(defun hm--html-add-abstract () - "Adds the HTML tags for abstract text at the point in the current buffer." +(defun hm--html-add-script () + "Adds the HTML tags for script." (interactive) (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "" + "")) + + +(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 - "" + "")) + +(defun hm--html-add-style () + "Adds the HTML tags for style." + (interactive) + (hm--html-add-tags 'hm--html-insert-start-tag-with-newline + "")) + + +(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 + "")) (defun hm--html-add-strikethru () "Adds the HTML tags for Strikethru at the point in the current buffer." @@ -989,9 +956,9 @@ "Adds the HTML tags for Strikethru to the region." (interactive) (hm--html-add-tags-to-region 'hm--html-insert-start-tag - "" + "" 'hm--html-insert-end-tag - "")) + "")) (defun hm--html-add-superscript () @@ -1030,60 +997,6 @@ "")) -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - (defun hm--html-add-option () "Adds the HTML tags for Option at the point in the current buffer." (interactive) @@ -1102,239 +1015,6 @@ "")) -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - - -(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 - "" - 'hm--html-insert-end-tag - "")) - (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." @@ -1411,23 +1091,6 @@ ;;; Lists -(defun hm--html-add-listing () - "Adds the HTML tags for listing." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "" - 'hm--html-insert-end-tag-with-newline - "")) - - -(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 - "" - 'hm--html-insert-end-tag-with-newline - "")) - (defun hm--html-add-center () "Adds the HTML tags for center at the current point." (interactive) @@ -1607,9 +1270,6 @@ "
" 'hm--html-insert-end-tag-with-newline "
")) - -; 'hm--html-insert-start-tag -; "
")) (defun hm--html-add-description-title () @@ -2034,12 +1694,7 @@ (defun hm--html-add-link-target (name) "Adds the HTML tags for a link target at point in the current buffer." -; (interactive "sName (or RET for numeric): ") (interactive "sName: ") -; (and (string= name "") -; (progn -; (setq html-link-counter (1+ html-link-counter)) -; (setq name (format "%d" html-link-counter)))) (hm--html-add-tags 'hm--html-insert-start-tag (concat "") 'hm--html-insert-end-tag @@ -2067,25 +1722,6 @@ (if extent (delete-extent extent))) -; ) -; ;; For the Emacs 19 -; (defun hm--html-mark-example (parameter-list) -; "Marks the example of the parameterlist in the current buffer. -;It returns the example extent." -; (if (hm--html-get-example-from-parameter-list parameter-list) -; (progn -; (search-forward (hm--html-get-example-from-parameter-list -; parameter-list)) -; (put-text-property (match-beginning 0) -; (match-end 0) -; 'face -; 'hm--html-help-face)))) -; -; -; (defun hm--html-unmark-example (extent) -; "Unmarks the example for the current question." -; t)) - (defun hm--html-write-alist-in-buffer (alist) "The function writes the contents of the ALIST in the currentbuffer." @@ -2190,11 +1826,6 @@ nil))) (hm--html-unmark-example marked-object) (hm--html-delete-wrong-path-prefix filename)) -; (if (not hm--html-delete-wrong-path-prefix) -; filename -; (if (string-match hm--html-delete-wrong-path-prefix filename) -; (substring filename (match-end 0)) -; filename))) "")) @@ -2228,7 +1859,6 @@ (defun hm--html-generate-help-buffer-faces () "Generates faces for the add-link-help-buffer." (if (not (facep 'hm--html-help-face)) -; (if (not hm--html-faces-exist) (progn (setq hm--html-faces-exist t) (make-face 'hm--html-help-face) @@ -3099,7 +2729,6 @@ (interactive "sNode Link to: ") (hm--html-add-tags-to-region 'hm--html-insert-start-tag (concat "") 'hm--html-insert-end-tag @@ -3142,7 +2771,8 @@ (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]*[0-3]?[0-9]-[A-Z][a-z][a-z]-[0-9][0-9][0-9][0-9]" + "[ \t]*\\)" "\\()[ \t\n]*\\)") end-of-head t) @@ -3198,7 +2828,6 @@ USERNAME is the name to be inserted in the comment." (if newline (progn -; (end-of-line) (newline))) (hm--html-add-comment) (insert "Changed by: " username ", " (hm--date))) @@ -3282,8 +2911,6 @@ (if filename (tmpl-insert-template-file filename) (call-interactively 'tmpl-insert-template-file)) -; (if hm--html-automatic-created-comment ; better in the template files -; (hm--html-insert-created-comment t) )) (defun hm--html-insert-template-from-fixed-dirs (filename) @@ -3304,42 +2931,8 @@ (if filename (tmpl-insert-template-file-from-fixed-dirs filename) (call-interactively 'tmpl-insert-template-file-from-fixed-dirs)) -; (if hm--html-automatic-created-comment ; better in the template files -; (hm--html-insert-created-comment t) )) -;(defun hm--html-insert-template (filename) -; "Inserts a templatefile." -; (interactive -; (list (tmpl-read-template-filename hm--html-template-dir -; hm--html-automatic-expand-templates -; hm--html-template-filter-regexp -; 'hm--html-template-file-history))) -; (interactive (list -; (let ((file-name-history hm--html-template-file-history)) -; (read-file-name "Templatefile: " -; hm--html-template-dir -; nil -; t -; nil)))) -;; 'hm--html-template-file-history))) -; (insert-file (expand-file-name filename)) -; (if hm--html-automatic-expand-templates -; (tmpl-expand-templates-in-buffer)) -; (if hm--html-automatic-created-comment -; (hm--html-insert-created-comment t))) - - - -;;; Functions for highlighting - -;(defun hm--html-toggle-use-highlighting () -; "Toggles the variable html-use-highlighting." -; (interactive) -; (if html-use-highlighting -; (setq html-use-highlighting nil) -; (setq html-use-highlighting t))) - ;;; Functions for font lock mode @@ -3357,44 +2950,9 @@ (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-doc-string-face 'font-lock-doc-string-face) (setq font-lock-string-face 'font-lock-string-face))) -;(defun hm--html-set-font-lock-color () -; "Sets the color for the font lock mode in HTML mode. -;This color is used to highlight HTML expressions." -; (interactive) -; (setq hm--html-font-lock-color -; (completing-read "Color: " -; '(("grey80") -; ("black") -; ("red") -; ("yellow") -; ("blue")) -; nil -; nil -; "black")) -; (set-face-foreground 'font-lock-comment-face hm--html-font-lock-color) -; (set-face-foreground 'font-lock-string-face hm--html-font-lock-color)) - - -;;; Functions which determine if an active region exists - -;(defvar hm--region-active nil -; "t : Region is active. -;nil: Region is inactive.") -; -; -;(defun hm--set-hm--region-active () -; (setq hm--region-active t)) -; -; -;(defun hm--unset-hm--region-active () -; (setq hm--region-active nil)) - - - ;;; Functions to insert forms (defun hm--html-form-read-method () @@ -4496,7 +4054,9 @@ (defun hm--html-view-www-package-docu () "View the WWW documentation of the package." (interactive) - (w3-fetch "http://www.tnt.uni-hannover.de:80/data/info/www/tnt/soft/info/www/html-editors/hm--html-menus/overview.html")) + (w3-fetch (concat "http://www.tnt.uni-hannover.de" + "/~muenkel/software/own/hm--html-menus/overview.html"))) + ;;; ; Bug reporting @@ -4557,15 +4117,9 @@ 'hm--html-wais-path-alist 'hm--html-wais-servername:port-alist 'hm--html-wais-servername:port-default -; 'html-deemphasize-color 'html-document-previewer -; 'html-document-previewer-args -; 'html-emphasize-color -; 'html-quotify-hrefs-on-find 'hm--html-region-mode 'html-sigusr1-signal-value -; 'html-use-font-lock -; 'html-use-highlighting ) nil nil @@ -4582,11 +4136,9 @@ (add-hook 'zmacs-activate-region-hook 'hm--html-switch-region-modes-on) -; (function (lambda () (hm--html-region-mode 1)))) (add-hook 'zmacs-deactivate-region-hook 'hm--html-switch-region-modes-off) -; (function (lambda () (hm--html-region-mode -1)))) ) @@ -4594,28 +4146,13 @@ (add-hook 'activate-mark-hook 'hm--html-switch-region-modes-on) -; (function (lambda () (hm--html-region-mode t)))) (add-hook 'deactivate-mark-hook 'hm--html-switch-region-modes-off) -; (function (lambda () (hm--html-region-mode nil)))) ) -;(add-hook 'hm--html-mode-hook -; (function -; (lambda () -; (make-variable-buffer-local 'write-file-hooks) -; (add-hook 'write-file-hooks -; 'hm--html-maybe-new-date-and-changed-comment)))) - -;(add-hook 'zmacs-activate-region-hook 'hm--set-hm--region-active) -; -;(add-hook 'zmacs-deactivate-region-hook 'hm--unset-hm--region-active) - - - ;;; ; Environment loading ; @@ -4675,76 +4212,6 @@ ) - -;(hm--html-load-config-files) - -;;; Definition of the minor mode html-region-mode - -;(defvar html-region-mode nil -; "*t, if the minor mode html-region-mode is on and nil otherwise.") - -;(make-variable-buffer-local 'html-region-mode) - -;(defvar html-region-mode-map nil "") - -;(hm--html-load-config-files) - -;(if hm--html-use-old-keymap -; (progn - -;;(setq minor-mode-alist (cons '(html-region-mode " Region") minor-mode-alist)) -;(or (assq 'html-region-mode minor-mode-alist) -; (setq minor-mode-alist -; (purecopy -; (append minor-mode-alist -; '((html-region-mode " Region")))))) - -;(defun html-region-mode (on) -; "Turns the minor mode html-region-mode on or off. -;The function turns the html-region-mode on, if ON is t and off otherwise." -; (if (string= mode-name "HTML") -; (if on -; ;; html-region-mode on -; (progn -; (setq html-region-mode t) -; (use-local-map html-region-mode-map)) -; ;; html-region-mode off -; (setq html-region-mode nil) -; (use-local-map html-mode-map)))) - -;)) - - - - - -;;; -; Set font lock color -; (hm--html-font-lock-color should be defined in hm--html-configuration.el -; oder .hm--html-configuration.el) -; -;(require 'font-lock) -;(load-library "font-lock") -;(set-face-foreground 'font-lock-comment-face hm--html-font-lock-color) - - -;(hm--html-generate-help-buffer-faces) - - - - -;;;;;;;; -;(setq hm--html-hostname-search-string -; "[-a-zA-Z0-9]*\\.[-a-zA-Z0-9]*\\.[-a-zA-Z0-9.]*") -; -;(defun hm--html-get-next-hostname () -; (interactive) -; (search-forward-regexp hm--html-hostname-search-string) -; (buffer-substring (match-beginning 0) (match-end 0))) -; - -;;; Announce the feature hm--html-configuration - ;;; quotify href (defvar hm--html-quotify-href-regexp diff -r a0ec055d74dd -r a145efe76779 lisp/modes/python-mode.el --- a/lisp/modes/python-mode.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/modes/python-mode.el Mon Aug 13 09:15:49 2007 +0200 @@ -6,8 +6,8 @@ ;; 1992-1994 Tim Peters ;; Maintainer: python-mode@python.org ;; Created: Feb 1992 -;; Version: 2.89 -;; Last Modified: 1997/01/30 20:16:18 +;; Version: 2.90 +;; Last Modified: 1997/02/24 03:37:22 ;; Keywords: python languages oop ;; This software is provided as-is, without express or implied @@ -208,7 +208,7 @@ displayed in the echo area, and if `py-beep-if-tab-change' is non-nil the Emacs bell is also rung as a warning.") -(defconst python-font-lock-keywords +(defvar python-font-lock-keywords (let* ((keywords '("and" "break" "class" "continue" "def" "del" "elif" "else:" "except" "except:" "exec" @@ -234,6 +234,8 @@ 1 font-lock-function-name-face) )) "Additional expressions to highlight in Python mode.") +(put 'python-mode 'font-lock-defaults '(python-font-lock-keywords)) + (defvar imenu-example--python-show-method-args-p nil "*Controls echoing of arguments of functions & methods in the imenu buffer. @@ -716,7 +718,6 @@ (setq major-mode 'python-mode mode-name "Python" local-abbrev-table python-mode-abbrev-table - font-lock-defaults '(python-font-lock-keywords) paragraph-separate "^[ \t]*$" paragraph-start "^[ \t]*$" require-final-newline t @@ -2411,7 +2412,7 @@ nil))) -(defconst py-version "2.89" +(defconst py-version "2.90" "`python-mode' version number.") (defconst py-help-address "python-mode@python.org" "Address accepting submission of bug reports.") diff -r a0ec055d74dd -r a145efe76779 lisp/modes/xrdb-mode.el --- a/lisp/modes/xrdb-mode.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/modes/xrdb-mode.el Mon Aug 13 09:15:49 2007 +0200 @@ -3,8 +3,8 @@ ;; Author: 1994-1997 Barry A. Warsaw ;; Maintainer: tools-help@python.org ;; Created: May 1994 -;; Version: 1.17 -;; Last Modified: 1997/02/21 22:28:59 +;; Version: 1.21 +;; Last Modified: 1997/02/24 03:34:56 ;; Keywords: data languages ;; Copyright (C) 1994 Barry A. Warsaw @@ -46,7 +46,22 @@ ;; don't intend to do any work on it any more... unless I lose my ;; place in paradise. I promise to be good, Steve. :-) :-)" ;; -;; I have fallen from grace. +;; I have fallen from grace and have been kicked out of paradise. So +;; has Steve Jobs apparently :-) +;; +;; To use, put the following in your .emacs: +;; +;; (autoload 'xrdb-mode "xrdb-mode" "Mode for editing X resource files" t) +;; +;; You may also want something like: +;; +;; (setq auto-mode-alist +;; (append '(("\\.Xdefaults$" . xrdb-mode) +;; ("\\.Xenvironment$" . xrdb-mode) +;; ("\\.Xresources$" . xrdb-mode) +;; ) +;; auto-mode-alist)) + ;; Code: @@ -338,21 +353,28 @@ ;; faces and font-locking -(require 'font-lock) +(defvar xrdb-option-name-face 'xrdb-option-name-face + "Face for option name on a line in an X resource db file") +(defvar xrdb-option-value-face 'xrdb-option-value-face + "Face for option value on a line in an X resource db file") + (make-face 'xrdb-option-name-face) (make-face 'xrdb-option-value-face) -(or (face-differs-from-default-p 'xrdb-option-name-face) - (copy-face 'font-lock-keyword-face 'xrdb-option-name-face)) -(or (face-differs-from-default-p 'xrdb-option-value-face) - (copy-face 'font-lock-string-face 'xrdb-option-value-face)) + +(defun xrdb-font-lock-mode-hook () + (or (face-differs-from-default-p 'xrdb-option-name-face) + (copy-face 'font-lock-keyword-face 'xrdb-option-name-face)) + (or (face-differs-from-default-p 'xrdb-option-value-face) + (copy-face 'font-lock-string-face 'xrdb-option-value-face)) + (remove-hook 'font-lock-mode-hook 'xrdb-font-lock-mode-hook)) +(add-hook 'font-lock-mode-hook 'xrdb-font-lock-mode-hook) (defvar xrdb-font-lock-keywords (list '("^[ \t]*\\([^\n:]*:\\)[ \t]*\\(.*\\)$" (1 xrdb-option-name-face) (2 xrdb-option-value-face))) - "Additional expressions to highlight in Xrdb mode.") - -(put 'xrdb-mode 'font-lock-defaults '(xrdb-font-lock-keywords nil)) + "Additional expressions to highlight in X resource db mode.") +(put 'xrdb-mode 'font-lock-defaults '(xrdb-font-lock-keywords)) @@ -380,7 +402,7 @@ ;; submitting bug reports -(defconst xrdb-version "1.17" +(defconst xrdb-version "1.21" "xrdb-mode version number.") (defconst xrdb-mode-help-address "tools-help@python.org" diff -r a0ec055d74dd -r a145efe76779 lisp/mule/chinese-hooks.el --- a/lisp/mule/chinese-hooks.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/mule/chinese-hooks.el Mon Aug 13 09:15:49 2007 +0200 @@ -186,7 +186,8 @@ (set-default-file-coding-system 'euc-china) (setq keyboard-coding-system 'euc-china) (setq terminal-coding-system 'euc-china) - (set-charset-registry 'ascii "gb1988"))) + (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)))) diff -r a0ec055d74dd -r a145efe76779 lisp/mule/japanese-hooks.el --- a/lisp/mule/japanese-hooks.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/mule/japanese-hooks.el Mon Aug 13 09:15:49 2007 +0200 @@ -180,7 +180,8 @@ (set-default-file-coding-system 'euc-japan) (setq keyboard-coding-system 'euc-japan) (setq terminal-coding-system 'euc-japan) - (set-charset-registry 'ascii "JISX0201") + (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 diff -r a0ec055d74dd -r a145efe76779 lisp/mule/korean-hooks.el --- a/lisp/mule/korean-hooks.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/mule/korean-hooks.el Mon Aug 13 09:15:49 2007 +0200 @@ -98,7 +98,8 @@ (set-default-file-coding-system 'euc-korea) (setq keyboard-coding-system 'euc-korea) (setq terminal-coding-system 'euc-korea) - (set-charset-registry 'ascii "ksc5636") + (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) diff -r a0ec055d74dd -r a145efe76779 lisp/mule/mule-coding.el --- a/lisp/mule/mule-coding.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/mule/mule-coding.el Mon Aug 13 09:15:49 2007 +0200 @@ -27,17 +27,24 @@ ;;; Code: +(defun set-keyboard-coding-system (coding-system) + "Set the coding system used for TTY keyboard input. Currently broken." + (interactive "zkeyboard-coding-system: ") + (get-coding-system coding-system) ; correctness check + (setq keyboard-coding-system coding-system) + (redraw-modeline t)) + (defun set-terminal-coding-system (coding-system) - "Set the coding system used for TTY display output." + "Set the coding system used for TTY display output. Currently broken." (interactive "zterminal-coding-system: ") - (get-coding-system coding-system) ;; correctness check + (get-coding-system coding-system) ; correctness check (setq terminal-coding-system coding-system) (redraw-modeline t)) (defun set-pathname-coding-system (coding-system) "Set the coding system used for file system path names." (interactive "zPathname-coding-system: ") - (get-coding-system coding-system) ;; correctness check + (get-coding-system coding-system) ; correctness check (setq pathname-coding-system coding-system)) (defun what-coding-system (start end &optional arg) @@ -109,33 +116,29 @@ (defun coding-system-charset (coding-system register) "Return the 'charset property of CODING-SYSTEM for the specified REGISTER." - (cond ((not (integerp register)) - (signal 'wrong-type-argument (list 'integerp register))) - ((= register 0) - (coding-system-property coding-system 'charset-g0)) - ((= register 1) - (coding-system-property coding-system 'charset-g1)) - ((= register 2) - (coding-system-property coding-system 'charset-g2)) - ((= register 3) - (coding-system-property coding-system 'charset-g3)) - (t - (signal 'args-out-of-range (list register 0 3))))) + (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." - (cond ((not (integerp register)) - (signal 'wrong-type-argument (list 'integerp register))) - ((= register 0) - (coding-system-property coding-system 'force-g0-on-output)) - ((= register 1) - (coding-system-property coding-system 'force-g1-on-output)) - ((= register 2) - (coding-system-property coding-system 'force-g2-on-output)) - ((= register 3) - (coding-system-property coding-system 'force-g3-on-output)) - (t - (signal 'args-out-of-range (list register 0 3))))) + (unless (integerp register) + (signal 'wrong-type-argument (list 'integerp register))) + (coding-system-property + coding-system + (case register + (0 'force-g0-on-output) + (1 'force-g1-on-output) + (2 'force-g2-on-output) + (3 'force-g3-on-output) + (t (signal 'args-out-of-range (list register 0 3)))))) (defun coding-system-short (coding-system) "Return the 'short property of CODING-SYSTEM." @@ -157,13 +160,13 @@ "Return the 'lock-shift property of CODING-SYSTEM." (coding-system-property coding-system 'lock-shift)) -(defun coding-system-use-japanese-jisx0201-roman (coding-system) - "Return the 'use-japanese-jisx0201-roman property of CODING-SYSTEM." - (coding-system-property coding-system 'use-japanese-jisx0201-roman)) +;;(defun coding-system-use-japanese-jisx0201-roman (coding-system) +;; "Return the 'use-japanese-jisx0201-roman property of CODING-SYSTEM." +;; (coding-system-property coding-system 'use-japanese-jisx0201-roman)) -(defun coding-system-use-japanese-jisx0208-1978 (coding-system) - "Return the 'use-japanese-jisx0208-1978 property of CODING-SYSTEM." - (coding-system-property coding-system 'use-japanese-jisx0208-2978)) +;;(defun coding-system-use-japanese-jisx0208-1978 (coding-system) +;; "Return the 'use-japanese-jisx0208-1978 property of CODING-SYSTEM." +;; (coding-system-property coding-system 'use-japanese-jisx0208-2978)) (defun coding-system-no-iso6429 (coding-system) "Return the 'no-iso6429 property of CODING-SYSTEM." @@ -194,6 +197,10 @@ mnemonic "CText" )) +;;; iso-8859-1 and ctext are aliases. + +(copy-coding-system 'ctext 'iso-8859-1) + (make-coding-system 'iso-2022-ss2-8 'iso2022 "ISO-2022 coding system using SS2 for 96-charset in 8-bit code." diff -r a0ec055d74dd -r a145efe76779 lisp/mule/mule-debug.el --- a/lisp/mule/mule-debug.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/mule/mule-debug.el Mon Aug 13 09:15:49 2007 +0200 @@ -44,100 +44,94 @@ "NAME REGISTRY BYTES CHARS FINAL GRAPHIC DIR\n") (princ "--------------------------------------------------------------------") - (mapcar - (lambda (name) - (let ((charset (get-charset name))) - (princ (format - "%20s %15s %5d %5d %5d %7d %s\n" - name - (charset-registry charset) - (charset-dimension charset) - (charset-chars charset) - (charset-final charset) - (charset-graphic charset) - (charset-direction charset))) - (princ " ") - (princ "%s\n" (charset-doc-string charset)))) - (charset-list)) + (dolist (charset (charset-list)) + (setq charset (get-charset charset)) + (princ (format + "%20s %15s %5d %5d %5d %7d %s\n" + (charset-name charset) + (charset-registry charset) + (charset-dimension charset) + (charset-chars charset) + (charset-final charset) + (charset-graphic charset) + (charset-direction charset))) + (princ " ") + (princ "%s\n" (charset-doc-string charset))))) - (princ "## CCL PROGRAM TO CONVERT INTERNAL TO EXTERNAL CODE\n") - (princ "NAME CCL-PROGRAMS\n") - (mapcar - (lambda (name) - (let ((ccl (charset-ccl-program name))) - (if ccl - (let ((i 0) (len (length ccl))) - (princ (format "%20s " name)) - (while (< i len) - (princ (format " %x" (aref ccl i))) - (setq i (1+ i))) - (princ "\n"))))) - (charset-list)) - )) +; (princ "## CCL PROGRAM TO CONVERT INTERNAL TO EXTERNAL CODE\n") +; (princ "NAME CCL-PROGRAMS\n") +; (mapcar +; (lambda (name) +; (let ((ccl (charset-ccl-program name))) +; (if ccl +; (let ((i 0) (len (length ccl))) +; (princ (format "%20s " name)) +; (while (< i len) +; (princ (format " %x" (aref ccl i))) +; (setq i (1+ i))) +; (princ "\n"))))) +; (charset-list)) +; )) -(defun describe-designation (flags graphic) - (let ((lc (aref flags graphic)) - lc1) - (if (integerp lc) (setq lc1 (if (> lc 0) lc (- lc)))) - (princ (format " G%d -- %s" - graphic - (or (and lc1 (char-description lc1)) - (and (eq lc t) "never used") - "none"))) - (princ (if (and lc1 (< lc 0)) - " (explicit designation required)\n" - "\n")))) -;; end of patch - +(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: ") - (get-coding-system cs);; correctness check + (setq cs (get-coding-system cs)) (with-output-to-temp-buffer "*Help*" - (princ "Coding-system ") - (princ cs) - (princ " [") - (princ (coding-system-mnemonic cs)) - (princ "]: \n") - (if (not cs) nil - (princ " ") - (princ (coding-system-doc-string cs)) - (princ "\nType: ") - (let ((type (coding-system-type cs))) - (princ type) - (cond ((eq type 'iso2022) - (princ "ISO-2022]\n") - (princ "Initial designations:\n") - (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 (aref flags 4) "ShortForm" "LongForm")) - (if (aref flags 5) (princ ", ASCII@EOL")) - (if (aref flags 6) (princ ", ASCII@CNTL")) - (princ (if (aref flags 7) ", 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")) - (princ ".\n")) - ((eq type 'big5) - (princ (if flags "Big-ETen\n" "Big-HKU\n"))) - )) - (princ "\nEOL-Type: ") - (let ((eol-type (coding-system-eol-type cs))) - (cond ((null eol-type) - (princ "null (= LF)\n")) - ((vectorp eol-type) - (princ "Automatic selection from ") - (princ eol-type) - (princ "\n")) - ((eq eol-type 1) (princ "LF\n")) - ((eq eol-type 2) (princ "CRLF\n")) - ((eq eol-type 3) (princ "CR\n")) - (t (princ "invalid\n")))) + (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 diff -r a0ec055d74dd -r a145efe76779 lisp/mule/mule-x-init.el --- a/lisp/mule/mule-x-init.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/mule/mule-x-init.el Mon Aug 13 09:15:49 2007 +0200 @@ -26,6 +26,42 @@ ;;; Code: +;;; Work around what is arguably a Sun CDE bug. + +(defun x-use-halfwidth-roman-font (fullwidth-charset roman-registry) + "Maybe set charset registry of the 'ascii charset to ROMAN-REGISTRY. + +Do this only if: + - the current display is an X device + - the displayed width of FULLWIDTH-CHARSET is twice the displayed + width of the 'ascii charset, but only when using ROMAN-REGISTRY. + +Traditionally, Asian characters have been displayed so that they +occupy exactly twice the screen space of ASCII (`halfwidth') +characters. On many systems, e.g. Sun CDE systems, this can only be +achieved by using a national variant roman font to display ASCII." + (let ((charset-font-width + (lambda (charset) + (font-instance-width + (face-font-instance 'default (selected-device) charset)))) + + (twice-as-wide + (lambda (cs1 cs2) + (let ((width1 (funcall charset-font-width cs1)) + (width2 (funcall charset-font-width cs2))) + (and width1 width2 (eq (+ width1 width1) width2)))))) + + (when (eq 'x (device-type)) + (condition-case nil + (unless (funcall twice-as-wide 'ascii fullwidth-charset) + (set-charset-registry 'ascii roman-registry) + (unless (funcall twice-as-wide 'ascii fullwidth-charset) + ;; Restore if roman-registry didn't help + (set-charset-registry 'ascii "iso8859-1"))) + (error (set-charset-registry 'ascii "iso8859-1")))))) + +;;;; + (defvar mule-x-win-initted nil) (defun init-mule-x-win () diff -r a0ec055d74dd -r a145efe76779 lisp/packages/balloon-help.el --- a/lisp/packages/balloon-help.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/packages/balloon-help.el Mon Aug 13 09:15:49 2007 +0200 @@ -57,7 +57,7 @@ (provide 'balloon-help) -(defvar balloon-help-version "1.03" +(defvar balloon-help-version "1.04" "Version string for Balloon Help.") (defvar balloon-help-mode t @@ -81,6 +81,9 @@ (defvar balloon-help-border-color "black" "*The color for displaying balloon help frame's border.") +(defvar balloon-help-border-width 2 + "*The width of the balloon help frame's border.") + (defvar balloon-help-use-sound nil "*Non-nil value means play a sound to herald the appearance and disappearance of the help frame. @@ -206,14 +209,20 @@ (top (cdr (assq 'top params))) (left (cdr (assq 'left params))) (xtop-toolbar-height - (if (specifier-instance top-toolbar) - (specifier-instance top-toolbar-height) + (if (and (specifier-instance top-toolbar-visible-p frame) + (specifier-instance top-toolbar frame)) + (specifier-instance top-toolbar-height frame) 0)) (xleft-toolbar-width - (if (specifier-instance left-toolbar) - (specifier-instance left-toolbar-width) + (if (and (specifier-instance left-toolbar-visible-p frame) + (specifier-instance left-toolbar frame)) + (specifier-instance left-toolbar-width frame) 0)) - (menubar-height (if current-menubar 22 0))) + (menubar-height + (if (and buffer + (specifier-instance menubar-visible-p) + (save-excursion (set-buffer buffer) current-menubar)) + 22 0))) (setq balloon-help-help-object-x (+ left xleft-toolbar-width (event-x-pixel event)) balloon-help-help-object-y @@ -335,6 +344,11 @@ (and (not done) (setq lines (1+ lines)))) (set-frame-size balloon-help-frame (+ 1 longest) lines)))) +(defun balloon-help-make-junk-frame () + (let ((window-min-height 1) + (window-min-width 1)) + (make-frame '(minibuffer t initially-unmapped t width 1 height 1)))) + (defun balloon-help-make-help-frame () (save-excursion (setq balloon-help-bar-cursor bar-cursor) @@ -349,11 +363,11 @@ ;; try to evade frame decorations (cons 'name (or balloon-help-frame-name "xclock")) - '(border-width . 2) + (cons 'border-width balloon-help-border-width) (cons 'border-color balloon-help-border-color) (cons 'top y) (cons 'left x) - (cons 'popup (selected-frame)) + (cons 'popup (balloon-help-make-junk-frame)) '(width . 3) '(height . 1))))) (set-face-font 'default balloon-help-font frame) @@ -373,6 +387,9 @@ (set-specifier bottom-toolbar (cons frame nil)) (set-specifier scrollbar-width (cons frame 0)) (set-specifier scrollbar-height (cons frame 0)) + (and (boundp 'text-cursor-visible-p) + (specifierp text-cursor-visible-p) + (set-specifier text-cursor-visible-p (cons frame nil))) (set-specifier modeline-shadow-thickness (cons frame 0)) (set-face-background 'modeline balloon-help-background frame) frame ))) @@ -392,4 +409,5 @@ (add-hook 'pre-command-hook 'balloon-help-pre-command-hook) (add-hook 'post-command-hook 'balloon-help-post-command-hook) (add-hook 'mouse-leave-frame-hook 'balloon-help-mouse-leave-frame-hook) -(add-hook 'deselect-frame-hook 'balloon-help-deselect-frame-hook) +;; loses with ClickToFocus under fvwm +;;(add-hook 'deselect-frame-hook 'balloon-help-deselect-frame-hook) diff -r a0ec055d74dd -r a145efe76779 lisp/packages/cu-edit-faces.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/packages/cu-edit-faces.el Mon Aug 13 09:15:49 2007 +0200 @@ -0,0 +1,47 @@ +;;; edit-faces.el -- interactive face editing mode + +;; Copyright (C) 1997 Jens Lautenbacher +;; +;; 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; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Synched up with: Not in FSF. + +;;; Just another TTPC (Totally Trivial Piece of Code (TM)). All the +;;; needed functionality for editing faces is already in custom.el. So +;;; why don't use it, you may ask. OK, here I am... + +(require 'custom) +(require 'cl) + +;;;###autoload +(defun cu-edit-faces () + (interactive) + (let (tmp-list elem) + (put 'available-faces 'custom-group nil) + (setq tmp-list (sort (face-list) + '(lambda (one two) + (if (string< (symbol-name one) + (symbol-name two)) t + nil)))) + (while (setq elem (pop tmp-list)) + (custom-add-to-group 'available-faces elem 'custom-face)) + (message "Please stand by while generating list of faces...") + (customize 'available-faces))) + +(provide 'cu-edit-faces) + +;;; cu-edit-faces.el ends here. diff -r a0ec055d74dd -r a145efe76779 lisp/packages/font-lock.el --- a/lisp/packages/font-lock.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/packages/font-lock.el Mon Aug 13 09:15:49 2007 +0200 @@ -274,12 +274,13 @@ (MATCH FACENAME OVERRIDE LAXMATCH) -Where MATCHER can be either the regexp to search for, or the function name to -call to make the search (called with one argument, the limit of the search). -MATCH is the subexpression of MATCHER to be highlighted. FACENAME is either -a symbol naming a face, or an expression whose value is the face name to use. -If you want FACENAME to be a symbol that evaluates to a face, use a form -like \"(progn sym)\". +Where MATCHER can be either the regexp to search for, a variable +containing the regexp to search for, or the function to call to make +the search (called with one argument, the limit of the search). MATCH +is the subexpression of MATCHER to be highlighted. FACENAME is either +a symbol naming a face, or an expression whose value is the face name +to use. If you want FACENAME to be a symbol that evaluates to a face, +use a form like \"(progn sym)\". OVERRIDE and LAXMATCH are flags. If OVERRIDE is t, existing fontification may be overwritten. If `keep', only parts not already fontified are highlighted. @@ -1127,6 +1128,10 @@ (eval (nth 1 keywords)) (save-match-data ;; Find an occurrence of `matcher' before `limit'. + (if (and (not (stringp matcher)) + (not (functionp matcher)) + (boundp matcher)) + (setq matcher (symbol-value matcher))) (while (if (stringp matcher) (re-search-forward matcher limit t) (funcall matcher limit)) @@ -1157,6 +1162,10 @@ ;; ;; Find an occurrence of `matcher' from `start' to `end'. (setq keyword (car keywords) matcher (car keyword)) + (if (and (not (stringp matcher)) + (not (functionp matcher)) + (boundp matcher)) + (setq matcher (symbol-value matcher))) (goto-char start) (while (and (< (point) end) (if (stringp matcher) @@ -2526,31 +2535,6 @@ )) "Additional expressions to highlight in sh-mode.") -(defconst python-font-lock-keywords - (purecopy - (list - (cons (concat "\\b\\(" - (mapconcat 'identity - '("access" "del" "from" - "lambda" "return" "and" - "elif" "global" "not" - "try:" "break " "else:" - "if" "or" "while" - "except" "except:" "import" - "pass" "continue" "finally:" - "in" "print" "for" - "is" "raise") - "\\|") - "\\)[ \n\t(]") - 1) - '("\\bclass[ \t]+\\([a-zA-Z_]+[a-zA-Z0-9_]*\\)" - 1 font-lock-type-face) - '("\\bdef[ \t]+\\([a-zA-Z_]+[a-zA-Z0-9_]*\\)" - 1 font-lock-function-name-face) - )) - "Additional expressions to highlight in Python mode.") - - ;; Install ourselves: diff -r a0ec055d74dd -r a145efe76779 lisp/packages/func-menu.el --- a/lisp/packages/func-menu.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/packages/func-menu.el Mon Aug 13 09:15:49 2007 +0200 @@ -546,13 +546,14 @@ ;;; Lisp ;;; ;;; Vladimir Alexiev +;;; JTL: 24. Feb. 97 added "/" as part of function names (defvar fume-function-name-regexp-lisp (concat "^[ \t]*" ; Allow whitespace |(or (fboundp 'foo) ; for the construct | (defun foo () "(\\(def[^vc][a-z]*\\)" ; Allow (def* except (defvar, (defconst "\\s-+" ; At least one whitespace - "'?[#:?A-Za-z0-9_+>-]+" ; Allow (defalias 'foo 'bar) + "'?[#:?/A-Za-z0-9_+>-]+" ; Allow (defalias 'foo 'bar) "\\s-*" ; Whitespace "\\(nil\\|(\\)" ; nil or (arg list ) diff -r a0ec055d74dd -r a145efe76779 lisp/packages/mic-paren.el --- a/lisp/packages/mic-paren.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/packages/mic-paren.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,8 +1,11 @@ -;;; mic-paren.el --- highlight matching paren. -;;; Version 1.2 - 96-09-19 -;;; Copyright (C) 1996 Mikael Sjödin (mic@docs.uu.se) +;;; mic-paren.el --- highlight matching parenthesises. +;;; Version 1.3 - 97-02-25 +;;; Copyright (C) 1997 Mikael Sjödin (mic@docs.uu.se) ;;; ;;; Author: Mikael Sjödin -- mic@docs.uu.se +;;; Additional code by: Vinicius Jose Latorre +;;; Steven L Baur +;;; ;;; Keywords: languages, faces ;;; ;;; This file is NOT part of GNU Emacs. @@ -34,6 +37,7 @@ ;;; (require 'mic-paren)) ;;; o Restart your Emacs. mic-paren is now installed and activated! ;;; o To list the possible customisation enter `C-h f paren-activate' +;;; ;;; ---------------------------------------------------------------------- ;;; Long Description: @@ -60,10 +64,23 @@ ;;; ;;; mic-paren.el is developed and tested under Emacs 19.28 - 19.34. It should ;;; work on earlier and forthcoming Emacs versions. XEmacs compatibility has -;;; been provided by Steven L Baur . +;;; been provided by Steven L Baur . Jan Dubois +;;; (jaduboi@ibm.net) provided help to get mic-paren to work in OS/2. ;;; ;;; This file can be obtained from http://www.docs.uu.se/~mic/emacs.html +;;; ---------------------------------------------------------------------- +;;; Versions: +;;; +;;; v1.3 Added code from Vinicius Jose Latorre to +;;; highlight unmathced parenthesises (useful in minibuffer) +;;; +;;; v1.2.1 Fixed stuff to work with OS/2 emx-emacs +;;; - checks if x-display-color-p is bound before calling it +;;; - changed how X/Lucid Emacs is deteced +;;; Added automatic load of the timer-feature (+ variable to disable +;;; the loading) + ;;; ====================================================================== ;;; User Options: @@ -166,12 +183,25 @@ ;;; ------------------------------ -(defvar paren-face (if (x-display-color-p) 'highlight 'underline) +(defvar paren-dont-load-timer (not (string-match "XEmacs\\|Lucid" + emacs-version)) + "*If non-nil mic-paren will not try to load the timer-feature when loaded. + +(I have no idea why you'd ever want to set this to non-nil but I hate packages +which loads/activates stuff I don't want to use so I provide this way to prevent +the loading if someone doesn't want timers to be loaded.)") + +;;; ------------------------------ + +(defvar paren-face (if (and (fboundp 'x-display-color-p) + (x-display-color-p)) + 'highlight 'underline) "*Face to use for showing the matching parenthesis.") ;;; ------------------------------ -(defvar paren-mismatch-face (if (x-display-color-p) +(defvar paren-mismatch-face (if (and (fboundp 'x-display-color-p) + (x-display-color-p)) (let ((fn 'paren-mismatch-face)) (copy-face 'default fn) (set-face-background fn "DeepPink") @@ -179,19 +209,28 @@ 'modeline) "*Face to use when highlighting a mismatched parenthesis.") +;;; ------------------------------ + +(defvar paren-no-match-face (if (x-display-color-p) + (let ((fn 'paren-no-match-face)) + (copy-face 'default fn) + (set-face-background fn "yellow") + fn) + 'default) + "*Face to use when highlighting an unmatched parenthesis.") + ;;; ====================================================================== ;;; User Functions: -;; XEmacs compatibility (by Steven L Baur ) +;; XEmacs compatibility (mainly by Steven L Baur ) (eval-and-compile - (if (fboundp 'make-extent) + (if (string-match "\\(Lucid\\|XEmacs\\)" emacs-version) (progn (fset 'mic-make-overlay 'make-extent) (fset 'mic-delete-overlay 'delete-extent) (fset 'mic-overlay-put 'set-extent-property) (defun mic-cancel-timer (timer) (delete-itimer timer)) - (defun mic-run-with-idle-timer (secs repeat function &rest args) - (start-itimer "mic-paren-idle" function secs nil)) + (fset 'mic-run-with-idle-timer 'start-itimer) ) (fset 'mic-make-overlay 'make-overlay) (fset 'mic-delete-overlay 'delete-overlay) @@ -318,7 +357,7 @@ (input-pending-p) ;[This might cause trouble since the ; function is unreliable] (condition-case paren-error - (mic-paren-highlight) + (mic-paren-highligt) (error (if (not (window-minibuffer-p (selected-window))) (message "mic-paren catched error (please report): %s" @@ -326,14 +365,14 @@ (defun mic-paren-command-idle-hook () (condition-case paren-error - (mic-paren-highlight) + (mic-paren-highligt) (error (if (not (window-minibuffer-p (selected-window))) (message "mic-paren catched error (please report): %s" paren-error))))) -(defun mic-paren-highlight () +(defun mic-paren-highligt () "The main-function of mic-paren. Does all highlighting, dinging, messages, cleaning-up." ;; Remove any old highlighting @@ -366,16 +405,16 @@ (error nil)))) ;; If match found - ;; highlight and/or print messages + ;; highlight expression and/or print messages ;; else + ;; highlight unmatched paren ;; print no-match message - ;; remove any old highlights (if open (let ((mismatch (/= (matching-paren (preceding-char)) (char-after open))) (visible (pos-visible-in-window-p open))) ;; If highlight is appropriate - ;; highlight + ;; highligt ;; else ;; remove any old highlight (if (or visible paren-highlight-offscreen paren-sexp-mode) @@ -420,6 +459,10 @@ (and mismatch paren-ding-unmatched (ding))) + (setq mic-paren-backw-overlay + (mic-make-overlay (1- (point)) (point))) + (mic-overlay-put mic-paren-backw-overlay + 'face paren-no-match-face) (and paren-message-no-match (not (window-minibuffer-p (selected-window))) (message "No opening parenthesis found")) @@ -451,16 +494,16 @@ (setq close (scan-sexps (point) 1)) (error nil)))) ;; If match found - ;; highlight and/or print messages + ;; highlight expression and/or print messages ;; else + ;; highligt unmatched paren ;; print no-match message - ;; remove any old highlights (if close (let ((mismatch (/= (matching-paren (following-char)) (char-after (1- close)))) (visible (pos-visible-in-window-p close))) ;; If highlight is appropriate - ;; highlight + ;; highligt ;; else ;; remove any old highlight (if (or visible paren-highlight-offscreen paren-sexp-mode) @@ -496,6 +539,10 @@ (and mismatch paren-ding-unmatched (ding))) + (setq mic-paren-forw-overlay + (mic-make-overlay (point) (1+ (point)))) + (mic-overlay-put mic-paren-forw-overlay + 'face paren-no-match-face) (and paren-message-no-match (not (window-minibuffer-p (selected-window))) (message "No closing parenthesis found")) @@ -563,6 +610,13 @@ ;;; ====================================================================== ;;; Initialisation when loading: +;;; Try to load the timer feature if its not already loaded +(or paren-dont-load-timer + (featurep 'timer) + (condition-case () + (require 'timer) + (error nil))) + (or paren-dont-activate-on-load (paren-activate)) diff -r a0ec055d74dd -r a145efe76779 lisp/prim/about.el --- a/lisp/prim/about.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/prim/about.el Mon Aug 13 09:15:49 2007 +0200 @@ -155,7 +155,7 @@ (toggle-read-only 0) (let ((rest (if who-to-load (list who-to-load) - '(steve mrb cthomp wing stig jwz mly vladimir baw piper bw wmperry kyle))) + '(steve mrb cthomp wing stig jwz mly vladimir baw piper bw wmperry kyle larsi))) (got-error nil)) (while rest (let* ((who (car rest)) @@ -205,7 +205,7 @@ (goto-char (point-max)) (insert "\n ") - (let ((rest '(steve mrb cthomp wing stig linebreak jwz mly vladimir linebreak baw piper bw linebreak wmperry kyle)) + (let ((rest '(steve mrb cthomp wing stig linebreak jwz mly vladimir linebreak baw piper bw linebreak wmperry kyle larsi)) (got-error nil)) (while rest (if (eq (car rest) 'linebreak) @@ -291,6 +291,7 @@ ('steve "About Steve Baur") ('mrb "About Martin Buchholz") ('kyle "About Kyle Jones") + ('larsi "About Lars Magne Ingebrigtsen") ('others "About Everyone") ('features "New XEmacs Features") ('history "XEmacs History") @@ -755,6 +756,24 @@ (insert " to go back to the previous page.\n") ) + ((eq xref 'larsi) + (about-face "Lars Magne Ingebrigtsen" 'bold) + (insert " + + Author of Gnus the Usenet news and Mail reading package in + the standard XEmacs distribution, and contributor of various + enhancements and portability fixes. Lars is a student at the + Institute of Informatics at the University of Oslo. He is + currently plumbing away at his majors work at the Institute of + Physics, working on an SCI project connected with CASCADE and + CERN and stuff. + See \"http://www.ifi.uio.no/~larsi/\".") + + (insert "\n\n\tClick ") + (about-xref "here" prev-page "Return to previous page") + (insert " to go back to the previous page.\n") + ) + ((eq xref 'others) (insert "Click ") (about-xref "here" 'about "Return to previous page") @@ -816,6 +835,16 @@ readers such as Berkeley Mail and ELM. See \"http://www.wonderworks.com/kyle/\" + ") (about-xref "Lars Magne Ingebrigtsen" 'larsi "Find out more about Lars Magne Ingebrigtsen") (insert " + Author of Gnus the Usenet news and Mail reading package in + the standard XEmacs distribution, and contributor of various + enhancements and portability fixes. Lars is a student at the + Institute of Informatics at the University of Oslo. He is + currently plumbing away at his majors work at the Institute of + Physics, working on an SCI project connected with CASCADE and + CERN and stuff. + See \"http://www.ifi.uio.no/~larsi/\" + Darrell Kindred Unofficial maintainer of the xemacs-beta list of extant bugs and contributor of an extraordinary number of important bug @@ -949,7 +978,6 @@ Stephan Herrmann Charles Hines David Hughes - Lars Magne Ingebrigtsen Andrew Innes Markku Jarvinen Robin Jeffries diff -r a0ec055d74dd -r a145efe76779 lisp/prim/auto-autoloads.el --- a/lisp/prim/auto-autoloads.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/prim/auto-autoloads.el Mon Aug 13 09:15:49 2007 +0200 @@ -1008,7 +1008,8 @@ Customize SYMBOL, which must be a variable." t nil) (autoload 'customize-face "custom-edit" "\ -Customize FACE." t nil) +Customize SYMBOL, which should be a face name or nil. +If SYMBOL is nil, customize all faces." t nil) (autoload 'customize-customized "custom-edit" "\ Customize all already customized user options." t nil) @@ -3735,7 +3736,7 @@ ;;;### (autoloads (ksh-mode) "ksh-mode" "modes/ksh-mode.el") (autoload 'ksh-mode "ksh-mode" "\ -ksh-mode $Revision: 1.10 $ - Major mode for editing (Bourne, Korn or Bourne again) +ksh-mode $Revision: 1.11 $ - Major mode for editing (Bourne, Korn or Bourne again) shell scripts. Special key bindings and commands: \\{ksh-mode-map} @@ -5087,7 +5088,7 @@ (autoload 'vhdl-mode "vhdl-mode" "\ Major mode for editing VHDL code. -vhdl-mode $Revision: 1.10 $ +vhdl-mode $Revision: 1.11 $ 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 @@ -5887,6 +5888,12 @@ ;;;*** +;;;### (autoloads (cu-edit-faces) "cu-edit-faces" "packages/cu-edit-faces.el") + +(autoload 'cu-edit-faces "cu-edit-faces" nil t nil) + +;;;*** + ;;;### (autoloads (dabbrev-expand dabbrev-completion) "dabbrev" "packages/dabbrev.el") (define-key global-map [(meta /)] 'dabbrev-expand) @@ -6306,12 +6313,13 @@ (MATCH FACENAME OVERRIDE LAXMATCH) -Where MATCHER can be either the regexp to search for, or the function name to -call to make the search (called with one argument, the limit of the search). -MATCH is the subexpression of MATCHER to be highlighted. FACENAME is either -a symbol naming a face, or an expression whose value is the face name to use. -If you want FACENAME to be a symbol that evaluates to a face, use a form -like \"(progn sym)\". +Where MATCHER can be either the regexp to search for, a variable +containing the regexp to search for, or the function to call to make +the search (called with one argument, the limit of the search). MATCH +is the subexpression of MATCHER to be highlighted. FACENAME is either +a symbol naming a face, or an expression whose value is the face name +to use. If you want FACENAME to be a symbol that evaluates to a face, +use a form like \"(progn sym)\". OVERRIDE and LAXMATCH are flags. If OVERRIDE is t, existing fontification may be overwritten. If `keep', only parts not already fontified are highlighted. @@ -9695,7 +9703,26 @@ ;;;*** -;;;### (autoloads (url-retrieve url-cache-expired url-popup-info url-get-url-at-point url-buffer-visiting url-normalize-url url-file-attributes) "url" "w3/url.el") +;;;### (autoloads (url-cache-expired url-extract-from-cache url-create-cached-filename url-is-cached url-store-in-cache) "url-cache" "w3/url-cache.el") + +(autoload 'url-store-in-cache "url-cache" "\ +Store buffer BUFF in the cache" nil nil) + +(autoload 'url-is-cached "url-cache" "\ +Return non-nil if the URL is cached." nil nil) + +(autoload 'url-create-cached-filename "url-cache" "\ +Return a filename in the local cache for URL" nil nil) + +(autoload 'url-extract-from-cache "url-cache" "\ +Extract FNAM from the local disk cache" nil nil) + +(autoload 'url-cache-expired "url-cache" "\ +Return t iff a cached file has expired." nil nil) + +;;;*** + +;;;### (autoloads (url-retrieve url-popup-info url-get-url-at-point url-buffer-visiting url-normalize-url url-file-attributes) "url" "w3/url.el") (autoload 'url-file-attributes "url" "\ Return a list of attributes of URL. @@ -9733,9 +9760,6 @@ (autoload 'url-popup-info "url" "\ Retrieve the HTTP/1.0 headers and display them in a temp buffer." nil nil) -(autoload 'url-cache-expired "url" "\ -Return t iff a cached file has expired." nil nil) - (autoload 'url-retrieve "url" "\ Retrieve a document over the World Wide Web. The document should be specified by its fully specified @@ -9758,7 +9782,7 @@ ;;;*** -;;;### (autoloads (w3-follow-link w3-follow-link-other-frame w3-do-setup w3 w3-preview-this-buffer w3-batch-fetch w3-follow-url-at-point w3-follow-url-at-point-other-frame w3-maybe-follow-link w3-maybe-follow-link-mouse w3-fetch w3-fetch-other-frame w3-find-file w3-open-local) "w3" "w3/w3.el") +;;;### (autoloads (w3-follow-link w3-follow-link-other-frame w3-do-setup w3 w3-preview-this-buffer w3-follow-url-at-point w3-follow-url-at-point-other-frame w3-maybe-follow-link w3-maybe-follow-link-mouse w3-fetch w3-fetch-other-frame w3-find-file w3-open-local) "w3" "w3/w3.el") (autoload 'w3-open-local "w3" "\ Find a local file, and interpret it as a hypertext document. @@ -9796,17 +9820,6 @@ (autoload 'w3-follow-url-at-point "w3" "\ Follow the URL under PT, defaults to link under (point)" t nil) -(autoload 'w3-batch-fetch "w3" "\ -Fetch all the URLs on the command line and save them to files in -the current directory. The first argument after the -f w3-batch-fetch -on the command line should be a string specifying how to save the -information retrieved. If it is \"html\", then the page will be -unformatted when it is written to disk. If it is \"text\", then the -page will be formatted before it is written to disk. If it is -\"binary\" it will not mess with the file extensions, and just save -the data in raw binary format. If none of those, the default is -\"text\", and the first argument is treated as a normal URL." nil nil) - (autoload 'w3-preview-this-buffer "w3" "\ See what this buffer will look like when its formatted as HTML. HTML is the HyperText Markup Language used by the World Wide Web to diff -r a0ec055d74dd -r a145efe76779 lisp/prim/files.el --- a/lisp/prim/files.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/prim/files.el Mon Aug 13 09:15:49 2007 +0200 @@ -1431,7 +1431,7 @@ ;; Parse the -*- line into the `result' alist. (cond ((not (search-forward "-*-" end t)) ;; doesn't have one. - nil) + (setq force t)) ((looking-at "[ \t]*\\([^ \t\n\r:;]+\\)\\([ \t]*-\\*-\\)") ;; Antiquated form: "-*- ModeName -*-". (setq result diff -r a0ec055d74dd -r a145efe76779 lisp/prim/itimer.el --- a/lisp/prim/itimer.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/prim/itimer.el Mon Aug 13 09:15:49 2007 +0200 @@ -55,7 +55,7 @@ ;; ;; See the doc strings of these functions for more information. -(defvar itimer-version "1.01" +(defvar itimer-version "1.02" "Version number of the itimer package.") (defvar itimer-list nil @@ -701,16 +701,23 @@ 'itimer-timer-driver nil nil)))) (defun itimer-time-difference (t1 t2) - ;; ignore high 16 bits since we will never be dealing with - ;; times that long. - (setq t1 (cdr t1) - t2 (cdr t2)) - (let ((usecs (- (nth 1 t1) (nth 1 t2))) - (secs (- (car t1) (car t2)))) - (if (< usecs 0) - (setq secs (1- secs) - usecs (+ usecs 1000000))) - (+ secs (/ usecs (if (featurep 'lisp-float-type) 1e6 1000000))))) + (let (usecs secs 65536-secs) + (setq usecs (- (nth 2 t1) (nth 2 t2))) + (if (< usecs 0) + (setq carry 1 + usecs (+ usecs 1000000)) + (setq carry 0)) + (setq secs (- (nth 1 t1) (nth 1 t2) carry)) + (if (< secs 0) + (setq carry 1 + secs (+ secs 65536)) + (setq carry 0)) + (setq 65536-secs (- (nth 0 t1) (nth 0 t2) carry)) + ;; loses for interval larger than the maximum signed Lisp integer. + ;; can't really be helped. + (+ (* 65536-secs 65536) + secs + (/ usecs (if (featurep 'lisp-float-type) 1e6 1000000))))) (defun itimer-timer-driver (&rest ignored) ;; inhibit quit because if the user quits at an inopportune diff -r a0ec055d74dd -r a145efe76779 lisp/prim/scrollbar.el --- a/lisp/prim/scrollbar.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/prim/scrollbar.el Mon Aug 13 09:15:49 2007 +0200 @@ -14,21 +14,23 @@ ;; 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. +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not in FSF. (Completely divergent from FSF scroll-bar.el) (defun init-scrollbar-from-resources (locale) - (if (and (featurep 'x) - (or (eq locale 'global) - (eq 'x (device-or-frame-type locale))) - (x-init-scrollbar-from-resources locale)))) + (when (and (featurep 'x) + (or (eq locale 'global) + (eq 'x (device-or-frame-type locale)))) + (x-init-scrollbar-from-resources locale))) ;; ;; vertical scrollbar functions ;; +;;; ### Move functions from C into Lisp here! ;; ;; horizontal scrollbar functions @@ -39,8 +41,7 @@ This is the little arrow to the left of the scrollbar. One argument is passed, the scrollbar's window. You can advise this function to change the scrollbar behavior." - (if (not (window-live-p window)) - nil + (when (window-live-p window) (scrollbar-set-hscroll window (- (window-hscroll window) 1)) (setq zmacs-region-stays t) nil)) @@ -50,8 +51,7 @@ This is the little arrow to the right of the scrollbar. One argument is passed, the scrollbar's window. You can advise this function to change the scrollbar behavior." - (if (not (window-live-p window)) - nil + (when (window-live-p window) (scrollbar-set-hscroll window (+ (window-hscroll window) 1)) (setq zmacs-region-stays t) nil)) @@ -61,8 +61,7 @@ \(The way this is done can vary from scrollbar to scrollbar.\) One argument is passed, the scrollbar's window. You can advise this function to change the scrollbar behavior." - (if (not (window-live-p window)) - nil + (when (window-live-p window) (scrollbar-set-hscroll window (- (window-hscroll window) (- (window-width window) 2))) (setq zmacs-region-stays t) @@ -73,8 +72,7 @@ \(The way this is done can vary from scrollbar to scrollbar.\) One argument is passed, the scrollbar's window. You can advise this function to change the scrollbar behavior." - (if (not (window-live-p window)) - nil + (when (window-live-p window) (scrollbar-set-hscroll window (+ (window-hscroll window) (- (window-width window) 2))) (setq zmacs-region-stays t) @@ -85,8 +83,7 @@ \(The way this is done can vary from scrollbar to scrollbar.\). One argument is passed, the scrollbar's window. You can advise this function to change the scrollbar behavior." - (if (not (window-live-p window)) - nil + (when (window-live-p window) (scrollbar-set-hscroll window 0) (setq zmacs-region-stays t) nil)) @@ -96,8 +93,7 @@ \(The way this is done can vary from scrollbar to scrollbar.\). One argument is passed, the scrollbar's window. You can advise this function to change the scrollbar behavior." - (if (not (window-live-p window)) - nil + (when (window-live-p window) (scrollbar-set-hscroll window 'max) (setq zmacs-region-stays t) nil)) @@ -108,9 +104,8 @@ representing how many columns the thumb is slid over. You can advise this function to change the scrollbar behavior." (let ((window (car data)) - (value (cdr data))) - (if (not (or (window-live-p window) (integerp value))) - nil + (value (cdr data))) + (when (and (window-live-p window) (integerp value)) (scrollbar-set-hscroll window value) (setq zmacs-region-stays t) nil))) diff -r a0ec055d74dd -r a145efe76779 lisp/site-load.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/site-load.el Mon Aug 13 09:15:49 2007 +0200 @@ -0,0 +1,58 @@ +;;; site-load.el --- Template file for site-wide XEmacs customization + +;; Author: Steven L. Baur +;; Keywords: internal + +;; This file is part of XEmacs. + +;;; Commentary: + +;; This is a prototype site-load.el file. +;; The site-load.el mechanism is provided so XEmacs installers can easily +;; dump lisp packages with XEmacs that do not get dumped standardly. + +;; The file `site-packages' if it exists should look something like: +;; (setq site-load-packages '( +;; "../lisp/modes/cc-mode" +;; "../lisp/utils/redo" +;; "../lisp/packages/scroll-in-place" +;; ) +;; ) + +;; The first line and the last line must be exact. Each of the packages +;; listed must be double quoted, have either an absolute path, or a relative +;; to the build src directory path *and* be bytecompiled prior to the attempt +;; to dump. + +;; Because this is a trial implementation and the file is shared with +;; make-docfiles, syntax is strict and unforgiving. So sue me. It +;; is still better than the way it used to be. + +;;; Code: +(defvar site-load-package-file "../lisp/site-packages" + "File name containing the list of extra packages to dump with XEmacs.") +(defvar site-load-packages nil + "A list of .elc files that should be dumped with XEmacs. +This variable should be set by `site-load-package-file'.") + +;; Load site specific packages for dumping with the XEmacs binary. +(when (file-exists-p site-load-package-file) + (let ((file)) + (load site-load-package-file t t t) + ;; The `load-gc' macro is provided as a clue that a package is being loaded + ;; in preparation of being dumped into XEmacs. + (defmacro load-gc (file) + (list 'prog1 (list 'load file) '(garbage-collect))) + (message "Loading site-wide packages for dumping...") + (while site-load-packages + (setq file (car site-load-packages)) + (load-gc file) + (setq site-load-packages (cdr site-load-packages))) + (message "Loading site-wide packages for dumping...done") + (fmakunbound 'load-gc))) + +;; This file is intended for end user additions. +;; Put other initialization here, like setting of language-environment, etc. +;; Perhaps this should really be in the site-init.el. + +;;; site-load.el ends here diff -r a0ec055d74dd -r a145efe76779 lisp/version.el --- a/lisp/version.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/version.el Mon Aug 13 09:15:49 2007 +0200 @@ -25,7 +25,7 @@ (defconst emacs-version "20.1" "Version numbers of this version of Emacs.") -(setq emacs-version (purecopy (concat emacs-version " XEmacs Lucid (beta2)"))) +(setq emacs-version (purecopy (concat emacs-version " XEmacs Lucid (beta3)"))) (defconst emacs-major-version (progn (or (string-match "^[0-9]+" emacs-version) diff -r a0ec055d74dd -r a145efe76779 lisp/vm/vm-delete.el --- a/lisp/vm/vm-delete.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/vm/vm-delete.el Mon Aug 13 09:15:49 2007 +0200 @@ -173,7 +173,7 @@ ;; all folder buffers. (vm-update-summary-and-mode-line) (if (not shaddap) - (vm-unsaved-message "Expunging...")) + (message "Expunging...")) (let ((use-marks (eq last-command 'vm-next-command-uses-marks)) (mp vm-message-list) (virtual (eq major-mode 'vm-virtual-mode)) diff -r a0ec055d74dd -r a145efe76779 lisp/vm/vm-digest.el --- a/lisp/vm/vm-digest.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/vm/vm-digest.el Mon Aug 13 09:15:49 2007 +0200 @@ -534,7 +534,7 @@ (setq digest-type (vm-guess-digest-type m)) (if (null digest-type) (error "Couldn't guess digest type.")))) - (vm-unsaved-message "Bursting %s digest..." digest-type) + (message "Bursting %s digest..." digest-type) (cond ((cond ((equal digest-type "mime") (vm-mime-burst-message m)) diff -r a0ec055d74dd -r a145efe76779 lisp/vm/vm-folder.el --- a/lisp/vm/vm-folder.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/vm/vm-folder.el Mon Aug 13 09:15:49 2007 +0200 @@ -919,9 +919,9 @@ (setq tail-cons (cdr tail-cons))) (vm-increment n) (if (zerop (% n modulus)) - (vm-unsaved-message "Parsing messages... %d" n))) + (message "Parsing messages... %d" n))) (if (>= n modulus) - (vm-unsaved-message "Parsing messages... done")) + (message "Parsing messages... done")) (if (and (not (= last-end (point-max))) (not (eq vm-folder-type 'unknown))) (progn @@ -1255,10 +1255,10 @@ ((vm-unread-flag (car mp)) (vm-increment vm-unread-count))) (if (zerop (% vm-total-count modulus)) - (vm-unsaved-message "Reading attributes... %d" vm-total-count)) + (message "Reading attributes... %d" vm-total-count)) (setq mp (cdr mp))) (if (>= vm-total-count modulus) - (vm-unsaved-message "Reading attributes... done")) + (message "Reading attributes... done")) (if (null message-list) (setq vm-totals (list vm-modification-counter vm-total-count @@ -1457,7 +1457,7 @@ (and got (or (not (equal vis vm-visible-headers)) (not (equal invis vm-invisible-header-regexp))) (let ((mp vm-message-list)) - (vm-unsaved-message "Discarding visible header info...") + (message "Discarding visible header info...") (while mp (vm-set-vheaders-regexp-of (car mp) nil) (vm-set-vheaders-of (car mp) nil) @@ -1483,7 +1483,7 @@ (vm-skip-past-leading-message-separator) (if (re-search-forward vm-message-order-header-regexp lim t) (progn - (vm-unsaved-message "Reordering messages...") + (message "Reordering messages...") (setq order (read (current-buffer)) list-length (length vm-message-list) v (make-vector (max list-length (length order)) nil)) @@ -1500,7 +1500,7 @@ vm-message-list)) (vm-set-numbering-redo-start-point t) (vm-reverse-link-messages)) - (vm-unsaved-message "Reordering messages... done"))))))) + (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 @@ -2114,7 +2114,7 @@ (if (and (not no-change) (not virtual)) (progn ;; this could take a while, so give the user some feedback - (vm-unsaved-message "Quitting...") + (message "Quitting...") (or vm-folder-read-only (eq major-mode 'vm-virtual-mode) (vm-change-all-new-to-unread)))) (if (and (buffer-modified-p) @@ -2122,7 +2122,7 @@ (not no-change) (not virtual)) (vm-save-folder)) - (vm-unsaved-message "") + (message "") (let ((summary-buffer vm-summary-buffer) (pres-buffer vm-presentation-buffer-handle) (mail-buffer (current-buffer))) @@ -2195,13 +2195,20 @@ (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))) + (set-itimer-restart current-itimer vm-mail-check-interval)) + ;; user has changed the variable value to a 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) (not vm-block-new-mail)) (progn (setq oldval vm-spooled-mail-waiting) @@ -2210,7 +2217,12 @@ (progn (intern (buffer-name) vm-buffers-needing-display-update) (vm-update-summary-and-mode-line)))))) - (setq b-list (cdr b-list))))) + (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 @@ -2222,12 +2234,19 @@ (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))) - (let ((b-list (buffer-list))) + (set-itimer-restart current-itimer vm-auto-get-new-mail)) + ;; user has changed the variable value to a 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 @@ -2244,7 +2263,12 @@ (vm-thoughtfully-select-message)) (vm-preview-current-message) (vm-update-summary-and-mode-line))))) - (setq b-list (cdr b-list))))) + (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 @@ -2345,7 +2369,7 @@ (if (buffer-modified-p) (let (mp (newlist nil)) ;; stuff the attributes of messages that need it. - (vm-unsaved-message "Stuffing attributes...") + (message "Stuffing attributes...") (vm-stuff-folder-attributes nil) ;; stuff bookmark and header variable values (if vm-message-list @@ -2358,7 +2382,7 @@ (vm-stuff-summary) (and vm-message-order-changed (vm-stuff-message-order)))) - (vm-unsaved-message "Saving...") + (message "Saving...") (let ((vm-inhibit-write-file-hook t)) (save-buffer prefix)) (vm-set-buffer-modified-p nil) @@ -2394,7 +2418,7 @@ '(vm-save-and-expunge-folder)) (if (not vm-folder-read-only) (progn - (vm-unsaved-message "Expunging...") + (message "Expunging...") (vm-expunge-folder t))) (vm-save-folder prefix)) @@ -2782,9 +2806,9 @@ (if (not (eq major-mode 'vm-mode)) (vm-mode)) (if (consp (car (vm-spool-files))) - (vm-unsaved-message "Checking for new mail for %s..." + (message "Checking for new mail for %s..." (or buffer-file-name (buffer-name))) - (vm-unsaved-message "Checking for new mail...")) + (message "Checking for new mail...")) (let (totals-blurb) (if (and (vm-get-spooled-mail t) (vm-assimilate-new-messages t)) (progn @@ -2801,7 +2825,7 @@ (message "No new mail for %s" (or buffer-file-name (buffer-name))) (message "No new mail.")) - (and (interactive-p) (sit-for 4) (vm-unsaved-message ""))))) + (and (interactive-p) (sit-for 4) (message ""))))) (t (let ((buffer-read-only nil) folder mcount totals-blurb) @@ -2970,7 +2994,7 @@ (while (and (sit-for 4) lines) (message (substitute-command-keys (car lines))) (setq lines (cdr lines))))) - (vm-unsaved-message "")) + (message "")) (defun vm-load-init-file (&optional interactive) (interactive "p") @@ -3167,7 +3191,7 @@ ;; process slower. (setq mp (cdr mp) n (1+ n)) (if (zerop (% n modulus)) - (vm-unsaved-message "Converting... %d" n)))))) + (message "Converting... %d" n)))))) (vm-clear-modification-flag-undos) (intern (buffer-name) vm-buffers-needing-display-update) (vm-update-summary-and-mode-line) diff -r a0ec055d74dd -r a145efe76779 lisp/vm/vm-mark.el --- a/lisp/vm/vm-mark.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/vm/vm-mark.el Mon Aug 13 09:15:49 2007 +0200 @@ -343,10 +343,12 @@ (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." +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) - (vm-unsaved-message "Next command uses marks...") + (message "Next command uses marks...") (vm-display nil nil '(vm-next-command-uses-marks) '(vm-next-command-uses-marks))) diff -r a0ec055d74dd -r a145efe76779 lisp/vm/vm-menu.el --- a/lisp/vm/vm-menu.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/vm/vm-menu.el Mon Aug 13 09:15:49 2007 +0200 @@ -269,29 +269,108 @@ ["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-replyto t] - [" Text" mail-text t] + ["Yank Original" vm-menu-yank-original vm-reply-list] "----" - ["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] + (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)])) "----" - "MIME:" - "----" - [" Attach File..." vm-mime-attach-file vm-send-using-mime] - [" Attach MIME File..." vm-mime-attach-mime-file vm-send-using-mime] - [" Encode MIME, But Don't Send" vm-mime-encode-composition + ["Attach File..." vm-mime-attach-file vm-send-using-mime] + ["Attach MIME File..." 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 + ["Preview MIME Before Sending" vm-mime-preview-composition vm-send-using-mime] )))) @@ -475,7 +554,7 @@ (let ((headers '("to" "cc" "bcc" "resent-to" "resent-cc" "resent-bcc")) h) (while headers - (setq h (mail-fetch-field (car 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))) @@ -839,20 +918,12 @@ ;; 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-mode-menu)) - ;; replace some FSF Emacs menubar menu commands so the - ;; user gets the VM version. Catch errors; we don't - ;; care enough about this to make VM crash if the - ;; menubar entry names change. - (condition-case nil - (progn - (define-key vm-mail-mode-map [menubar mail send] - 'vm-mail-send-and-exit) - (define-key vm-mail-mode-map [menubar mail send-stay] - 'vm-mail-send)) - (error nil))))) + 'vm-menu-popup-mode-menu))))) (defun vm-menu-install-menus () (cond ((consp vm-use-menus) @@ -1008,7 +1079,7 @@ (defun vm-menu-hm-make-folder-menu () "Makes a menu with the mail folders of the directory `vm-folder-directory'." (interactive) - (vm-unsaved-message "Building folders menu...") + (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) @@ -1065,7 +1136,7 @@ "----" ["Rebuild Folders Menu" vm-menu-hm-make-folder-menu vm-folder-directory] )))) - (vm-unsaved-message "Building folders menu... done") + (message "Building folders menu... done") (vm-menu-hm-install-menu)) (defun vm-menu-hm-install-menu () diff -r a0ec055d74dd -r a145efe76779 lisp/vm/vm-mime.el --- a/lisp/vm/vm-mime.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/vm/vm-mime.el Mon Aug 13 09:15:49 2007 +0200 @@ -153,7 +153,7 @@ (vm-mime-qp-decode-region start end))))) (defun vm-mime-base64-decode-region (start end &optional crlf) - (vm-unsaved-message "Decoding base64...") + (message "Decoding base64...") (let ((work-buffer nil) (done nil) (counter 0) @@ -219,11 +219,11 @@ (insert-buffer-substring work-buffer) (delete-region (point) end)) (and work-buffer (kill-buffer work-buffer)))) - (vm-unsaved-message "Decoding base64... done")) + (message "Decoding base64... done")) (defun vm-mime-base64-encode-region (start end &optional crlf B-encoding) (and (> (- end start) 200) - (vm-unsaved-message "Encoding base64...")) + (message "Encoding base64...")) (let ((work-buffer nil) (counter 0) (cols 0) @@ -244,7 +244,13 @@ vm-mime-base64-encoder-program vm-mime-base64-encoder-switches))) (if (not (eq status t)) - (vm-mime-error "%s" (cdr status)))) + (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))) @@ -286,13 +292,13 @@ (insert-buffer-substring work-buffer) (delete-region (point) end) (and (> (- end start) 200) - (vm-unsaved-message "Encoding base64... done")) + (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) - (vm-unsaved-message "Decoding quoted-printable...")) + (message "Decoding quoted-printable...")) (let ((work-buffer nil) (buf (current-buffer)) (case-fold-search nil) @@ -354,11 +360,11 @@ (delete-region (point) end)) (and work-buffer (kill-buffer work-buffer)))) (and (> (- end start) 200) - (vm-unsaved-message "Decoding quoted-printable... done"))) + (message "Decoding quoted-printable... done"))) (defun vm-mime-qp-encode-region (start end &optional Q-encoding) (and (> (- end start) 200) - (vm-unsaved-message "Encoding quoted-printable...")) + (message "Encoding quoted-printable...")) (let ((work-buffer nil) (buf (current-buffer)) (cols 0) @@ -402,7 +408,7 @@ (insert-buffer-substring work-buffer) (delete-region (point) end) (and (> (- end start) 200) - (vm-unsaved-message "Encoding quoted-printable... done")) + (message "Encoding quoted-printable... done")) (- end start)) (and work-buffer (kill-buffer work-buffer))))) @@ -480,13 +486,11 @@ (or pos (setq pos (point-max) done t)) (if charset (progn - (message " pos = %d start = %d" pos start) (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))))) - (message " pos = %d start = %d" pos start) (setq pos (+ start (if (setq q-encoding @@ -494,7 +498,6 @@ charset)) (vm-mime-Q-encode-region start pos) (vm-mime-B-encode-region start pos)))) - (message " pos = %d start = %d" pos start) (goto-char pos) (insert "?=") (setq pos (point)) @@ -605,7 +608,7 @@ (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) - (and m (vm-unsaved-message "Parsing MIME message...")) + (and m (message "Parsing MIME message...")) (prog1 (catch 'return-value (save-excursion @@ -788,7 +791,7 @@ (vm-marker (point-max)) (nreverse multipart-list) nil ))))) - (and m (vm-unsaved-message "Parsing MIME message... done")) + (and m (message "Parsing MIME message... done")) ))) (defun vm-mime-parse-entity-safe (&optional m c-t c-t-e) @@ -882,7 +885,7 @@ ;; Tell XEmacs/MULE not to mess with the text on writes. buffer-read-only t mode-line-format vm-mode-line-format) - (and (fboundp 'set-file-coding-system) + (and (vm-xemacs-mule-p) (set-file-coding-system 'binary t)) (cond ((vm-fsfemacs-19-p) ;; need to do this outside the let because @@ -1079,7 +1082,7 @@ (defun vm-mime-convert-undisplayable-layout (layout) (let ((ooo (vm-mime-can-convert (car (vm-mm-layout-type layout))))) - (vm-unsaved-message "Converting %s to %s..." + (message "Converting %s to %s..." (car (vm-mm-layout-type layout)) (nth 1 ooo)) (save-excursion @@ -1095,7 +1098,7 @@ (insert "Content-Type: " (nth 1 ooo) "\n") (insert "Content-Transfer-Encoding: binary\n\n") (set-buffer-modified-p nil) - (vm-unsaved-message "Converting %s to %s... done" + (message "Converting %s to %s... done" (car (vm-mm-layout-type layout)) (nth 1 ooo)) (vector (list (nth 1 ooo)) @@ -1220,7 +1223,7 @@ (vm-preview-current-message))) (let ((layout (vm-mm-layout (car vm-message-pointer))) (m (car vm-message-pointer))) - (vm-unsaved-message "Decoding MIME message...") + (message "Decoding MIME message...") (cond ((stringp layout) (error "Invalid MIME message: %s" layout))) (if (vm-mime-plain-message-p m) @@ -1251,7 +1254,7 @@ (setq vm-mime-decoded 'decoded)) (intern (buffer-name vm-mail-buffer) vm-buffers-needing-display-update) (vm-update-summary-and-mode-line) - (vm-unsaved-message "Decoding MIME message... done")))) + (message "Decoding MIME message... done")))) (vm-display nil nil '(vm-decode-mime-message) '(vm-decode-mime-message reading-message))) @@ -1322,7 +1325,7 @@ ;;(defun vm-mime-display-internal-text/html (layout) ;; (let ((buffer-read-only nil) ;; (work-buffer nil)) -;; (vm-unsaved-message "Inlining text/html, be patient...") +;; (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 @@ -1337,7 +1340,7 @@ ;; (w3-region (point-min) (point-max))))) ;; (insert-buffer-substring work-buffer)) ;; (and work-buffer (kill-buffer work-buffer))) -;; (vm-unsaved-message "Inlining text/html... done") +;; (message "Inlining text/html... done") ;; t )) (defun vm-mime-display-internal-text/plain (layout &optional ignore-urls) @@ -1361,7 +1364,7 @@ (let ((start (point)) end (buffer-read-only nil) (enriched-verbose t)) - (vm-unsaved-message "Decoding text/enriched, be patient...") + (message "Decoding text/enriched, be patient...") (vm-mime-insert-mime-body layout) (setq end (point-marker)) (vm-mime-transfer-decode-region layout start end) @@ -1374,7 +1377,7 @@ (enriched-decode start end) (vm-energize-urls-in-message-region start end) (goto-char end) - (vm-unsaved-message "Decoding text/enriched... done") + (message "Decoding text/enriched... done") t )) (defun vm-mime-display-external-generic (layout) @@ -1398,7 +1401,7 @@ (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 (fboundp 'set-file-coding-system) + (if (vm-xemacs-mule-p) (if (vm-mime-text-type-p layout) (set-file-coding-system 'no-conversion nil) (set-file-coding-system 'binary t))) @@ -1409,7 +1412,7 @@ (setq vm-folder-garbage-alist (cons (cons tempfile 'delete-file) vm-folder-garbage-alist))))) - (vm-unsaved-message "Launching %s..." (mapconcat 'identity + (message "Launching %s..." (mapconcat 'identity program-list " ")) (setq process @@ -1417,7 +1420,7 @@ (format "view %25s" (vm-mime-layout-description layout)) nil (append program-list (list tempfile)))) (process-kill-without-query process t) - (vm-unsaved-message "Launching %s... done" (mapconcat 'identity + (message "Launching %s... done" (mapconcat 'identity program-list " ")) (save-excursion @@ -1617,7 +1620,7 @@ (save-excursion (vm-mime-display-internal-message/partial layout)))) layout nil)) - (vm-unsaved-message "Assembling message...") + (message "Assembling message...") (let ((parts nil) (missing nil) (work-buffer nil) @@ -1721,7 +1724,7 @@ (goto-char (point-max)) (insert (vm-trailing-message-separator)) (set-buffer-modified-p nil) - (vm-unsaved-message "Assembling message... done") + (message "Assembling message... done") (vm-save-buffer-excursion (vm-goto-new-folder-frame-maybe 'folder) (vm-mode)) @@ -1747,14 +1750,14 @@ (setq tempfile (vm-make-tempfile-name)) ;; coding system for presentation buffer is binary (write-region start end tempfile nil 0) - (vm-unsaved-message "Creating %s glyph..." name) + (message "Creating %s glyph..." name) (setq g (make-glyph (list (vector feature ':file tempfile) (vector 'string ':data (format "[Unknown %s image encoding]\n" name))))) - (vm-unsaved-message "") + (message "") (vm-set-mm-layout-cache layout g) (save-excursion (vm-select-folder-buffer) @@ -1967,7 +1970,7 @@ (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 (fboundp 'set-file-coding-system) + (if (vm-xemacs-mule-p) (if (vm-mime-text-type-p layout) (set-file-coding-system 'no-conversion nil) (set-file-coding-system 'binary t))) @@ -2036,37 +2039,41 @@ (and work-buffer (kill-buffer work-buffer)))))) (defun vm-mime-layout-description (layout) - (if (vm-mm-layout-description layout) - (vm-mime-scrub-description (vm-mm-layout-description layout)) - (let ((type (car (vm-mm-layout-type layout))) - name) - (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))))) + (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))) @@ -2304,7 +2311,7 @@ (let ((o-list nil) (done nil) (pos start) - object pos props o) + object props o) (save-excursion (save-restriction (narrow-to-region start end) @@ -2426,7 +2433,7 @@ (narrow-to-region (point) (point-max)) (setq charset (vm-determine-proper-charset (point-min) (point-max))) - (if (fboundp 'encode-coding-region) + (if (vm-xemacs-mule-p) (encode-coding-region (point-min) (point-max) file-coding-system)) (setq encoding (vm-determine-proper-content-transfer-encoding @@ -2596,7 +2603,7 @@ nil (setq charset (vm-determine-proper-charset (point) (point-max))) - (if (fboundp 'encode-coding-region) + (if (vm-xemacs-mule-p) (encode-coding-region (point-min) (point-max) file-coding-system)) (setq encoding (vm-determine-proper-content-transfer-encoding @@ -2678,7 +2685,7 @@ (defun vm-mime-fragment-composition (size) (save-restriction (widen) - (vm-unsaved-message "Fragmenting message...") + (message "Fragmenting message...") (let ((buffers nil) (id (vm-mime-make-multipart-boundary)) (n 1) @@ -2738,7 +2745,7 @@ (vm-increment n) (set-buffer master-buffer) (setq start (point))) - (vm-unsaved-message "Fragmenting message... done") + (message "Fragmenting message... done") (nreverse buffers)))) (defun vm-mime-preview-composition () @@ -2755,25 +2762,11 @@ e-list) (unwind-protect (progn - (mail-text) - (setq e-list (if (fboundp 'extent-list) - (extent-list nil (point) (point-max)) - (overlays-in (point) (point-max))) - e-list (vm-delete (function - (lambda (e) - (vm-extent-property e 'vm-mime-object))) - e-list t) - e-list (sort e-list (function - (lambda (e1 e2) - (< (vm-extent-end-position e1) - (vm-extent-end-position e2)))))) (setq temp-buffer (generate-new-buffer "composition preview")) (set-buffer temp-buffer) ;; so vm-mime-encode-composition won't complain (setq major-mode 'mail-mode) (vm-insert-region-from-buffer mail-buffer) - (if (vm-fsfemacs-19-p) - (mapcar 'vm-copy-extent e-list)) (goto-char (point-min)) (or (vm-mail-mode-get-header-contents "From") (insert "From: " (or user-mail-address (user-login-name)) "\n")) diff -r a0ec055d74dd -r a145efe76779 lisp/vm/vm-minibuf.el --- a/lisp/vm/vm-minibuf.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/vm/vm-minibuf.el Mon Aug 13 09:15:49 2007 +0200 @@ -317,7 +317,7 @@ (set-buffer input-buffer) (while t (erase-buffer) - (vm-unsaved-message "%s%s" prompt + (message "%s%s" prompt (vm-truncate-string xxx (buffer-size))) (while (not (memq (setq char (read-char)) '(?\C-m ?\C-j))) (if (setq form @@ -333,11 +333,11 @@ (eval form) (error t)) (insert char)) - (vm-unsaved-message "%s%s" prompt + (message "%s%s" prompt (vm-truncate-string xxx (buffer-size)))) (cond ((and confirm string) (cond ((not (string= string (buffer-string))) - (vm-unsaved-message + (message (concat prompt (vm-truncate-string xxx (buffer-size)) " [Mismatch... try again.]")) @@ -347,13 +347,13 @@ (t (throw 'return-value string)))) (confirm (setq string (buffer-string)) - (vm-unsaved-message + (message (concat prompt (vm-truncate-string xxx (buffer-size)) " [Retype to confirm...]")) (sit-for 2)) (t - (vm-unsaved-message "") + (message "") (throw 'return-value (buffer-string)))))) (and input-buffer (kill-buffer input-buffer))))))) diff -r a0ec055d74dd -r a145efe76779 lisp/vm/vm-misc.el --- a/lisp/vm/vm-misc.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/vm/vm-misc.el Mon Aug 13 09:15:49 2007 +0200 @@ -108,7 +108,7 @@ ;; writing out message separators (setq buffer-file-type nil) ;; Tell XEmacs/MULE to pick the correct newline conversion. - (and (fboundp 'set-file-coding-system) + (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)))))) @@ -349,8 +349,9 @@ (defun vm-xemacs-mule-p () (and (vm-xemacs-p) + (featurep 'mule) (fboundp 'set-file-coding-system) - (fboundp 'decode-coding-region))) + (fboundp 'get-coding-system))) (defun vm-fsfemacs-19-p () (and (string-match "^19" emacs-version) @@ -502,10 +503,6 @@ (let ((o (make-extent start end))) (set-extent-property o 'face face))))) -(defun vm-unsaved-message (&rest args) - (let ((message-log-max nil)) - (apply (function message) args))) - (defun vm-default-buffer-substring-no-properties (beg end &optional buffer) (let ((s (if buffer (save-excursion diff -r a0ec055d74dd -r a145efe76779 lisp/vm/vm-mouse.el --- a/lisp/vm/vm-mouse.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/vm/vm-mouse.el Mon Aug 13 09:15:49 2007 +0200 @@ -184,12 +184,12 @@ (cond ((symbolp browser) (funcall browser url)) ((stringp browser) - (vm-unsaved-message "Sending URL to %s..." browser) + (message "Sending URL to %s..." browser) (vm-run-background-command browser url) - (vm-unsaved-message "Sending URL to %s... done" browser)))))) + (message "Sending URL to %s... done" browser)))))) (defun vm-mouse-send-url-to-netscape (url &optional new-netscape new-window) - (vm-unsaved-message "Sending URL to Netscape...") + (message "Sending URL to Netscape...") (if new-netscape (vm-run-background-command vm-netscape-program url) (or (equal 0 (vm-run-command vm-netscape-program "-remote" @@ -197,10 +197,10 @@ (if new-window ", new-window" "") ")"))) (vm-mouse-send-url-to-netscape url t new-window))) - (vm-unsaved-message "Sending URL to Netscape... done")) + (message "Sending URL to Netscape... done")) (defun vm-mouse-send-url-to-mosaic (url &optional new-mosaic new-window) - (vm-unsaved-message "Sending URL to Mosaic...") + (message "Sending URL to Mosaic...") (if (null new-mosaic) (let ((pid-file "~/.mosaicpid") (work-buffer " *mosaic work*") @@ -216,7 +216,7 @@ ;; newline convention used should be the local ;; one, whatever that is. (setq buffer-file-type nil) - (and (fboundp 'set-file-coding-system) + (and (vm-xemacs-mule-p) (set-file-coding-system 'no-conversion nil)) (write-region (point-min) (point-max) (concat "/tmp/Mosaic." pid) @@ -228,7 +228,7 @@ (setq new-mosaic t))))) (if new-mosaic (vm-run-background-command vm-mosaic-program url)) - (vm-unsaved-message "Sending URL to Mosaic... done")) + (message "Sending URL to Mosaic... done")) (defun vm-mouse-install-mouse () @@ -253,7 +253,11 @@ ;; 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) status errstring) + (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)) @@ -263,11 +267,15 @@ (list output-buffer tempfile) nil arg-list)) (cond ((equal status 0) t) - ((zerop (save-excursion - (set-buffer (find-file-noselect tempfile)) - (buffer-size))) + ;; even if exit status non-zero, if there was no + ;; diagnostic output the command probablyt + ;; succeeded. I have tried just use exit status + ;; as the failure criteria 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) diff -r a0ec055d74dd -r a145efe76779 lisp/vm/vm-page.el --- a/lisp/vm/vm-page.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/vm/vm-page.el Mon Aug 13 09:15:49 2007 +0200 @@ -187,10 +187,10 @@ (defun vm-emit-eom-blurb () (if (vm-full-name-of (car vm-message-pointer)) - (vm-unsaved-message "End of message %s from %s" + (message "End of message %s from %s" (vm-number-of (car vm-message-pointer)) (vm-full-name-of (car vm-message-pointer))) - (vm-unsaved-message "End of message %s" + (message "End of message %s" (vm-number-of (car vm-message-pointer))))) (defun vm-scroll-backward (arg) diff -r a0ec055d74dd -r a145efe76779 lisp/vm/vm-pop.el --- a/lisp/vm/vm-pop.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/vm/vm-pop.el Mon Aug 13 09:15:49 2007 +0200 @@ -187,7 +187,7 @@ (setq process-buffer (get-buffer-create (format "trace of POP session to %s" host))) ;; Tell XEmacs/MULE not to mess with the text. - (and (fboundp 'set-file-coding-system) + (and (vm-xemacs-mule-p) (set-file-coding-system 'binary t)) ;; clear the trace buffer of old output (save-excursion diff -r a0ec055d74dd -r a145efe76779 lisp/vm/vm-reply.el --- a/lisp/vm/vm-reply.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/vm/vm-reply.el Mon Aug 13 09:15:49 2007 +0200 @@ -719,7 +719,10 @@ (replace-match "") (goto-char (point-max))) (insert ?\n mail-header-separator ?\n) - (mail-position-on-field "To") + (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)) @@ -825,7 +828,7 @@ (goto-char (match-end 0)) (setq start (point-marker) header-end (match-beginning 0))) - (vm-unsaved-message "Building %s digest..." vm-digest-send-type) + (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 @@ -853,7 +856,7 @@ (setq mp mlist) (if prefix (progn - (vm-unsaved-message "Building digest preamble...") + (message "Building digest preamble...") (while mp (let ((vm-summary-uninteresting-senders nil)) (insert (vm-sprintf 'vm-digest-preamble-format (car mp)) "\n")) @@ -971,7 +974,6 @@ mode-popup-menu (and vm-use-menus vm-popup-menu-on-mouse-3 (vm-menu-support-possible-p) (vm-menu-mode-menu))) - ;; sets up popup menu for FSF Emacs (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 diff -r a0ec055d74dd -r a145efe76779 lisp/vm/vm-save.el --- a/lisp/vm/vm-save.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/vm/vm-save.el Mon Aug 13 09:15:49 2007 +0200 @@ -98,7 +98,7 @@ (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) - (vm-unsaved-message "Archiving...") + (message "Archiving...") (let ((auto-folder) (archived 0)) (unwind-protect @@ -135,7 +135,7 @@ (if (not (string-equal auto-folder "/dev/null")) (vm-save-message auto-folder)) (vm-increment archived) - (vm-unsaved-message "%d archived, still working..." + (message "%d archived, still working..." archived))) (setq done (eq vm-message-pointer stop-point) vm-message-pointer (cdr vm-message-pointer)))) diff -r a0ec055d74dd -r a145efe76779 lisp/vm/vm-sort.el --- a/lisp/vm/vm-sort.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/vm/vm-sort.el Mon Aug 13 09:15:49 2007 +0200 @@ -327,7 +327,7 @@ (setq key-funcs (cons 'vm-sort-compare-physical-order-r key-funcs))) (t (error "Unknown key: %s" key))) (setq key-list (cdr key-list))) - (vm-unsaved-message "Sorting...") + (message "Sorting...") (let ((vm-key-functions (nreverse key-funcs))) (setq new-message-list (sort (copy-sequence old-message-list) 'vm-sort-compare-xxxxxx)) @@ -337,7 +337,7 @@ (setq vm-key-functions '(vm-sort-compare-physical-order) physical-order-list (sort (copy-sequence old-message-list) 'vm-sort-compare-xxxxxx)))) - (vm-unsaved-message "Sorting... done") + (message "Sorting... done") (let ((inhibit-quit t)) (setq mp-old old-message-list mp-new new-message-list) @@ -377,7 +377,7 @@ ;; order header from being stuffed later. (vm-remove-message-order) (setq vm-message-order-changed nil) - (vm-unsaved-message "Moving messages... ") + (message "Moving messages... ") (widen) (setq mp-old physical-order-list mp-new new-message-list) @@ -400,7 +400,7 @@ ;; mp-old down one message by inserting a ;; message in front of it. (setq mp-new (cdr mp-new))))) - (vm-unsaved-message "Moving messages... done") + (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)) diff -r a0ec055d74dd -r a145efe76779 lisp/vm/vm-startup.el --- a/lisp/vm/vm-startup.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/vm/vm-startup.el Mon Aug 13 09:15:49 2007 +0200 @@ -64,36 +64,42 @@ (enable-local-variables nil) ;; for XEmacs/Mule (overriding-file-coding-system 'no-conversion)) - (vm-unsaved-message "Reading %s..." file) + (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)))) - (vm-unsaved-message "Reading %s... done" file)))))))) + (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 vm-mode + ;; This is only possible if a file is visited and then vm-mode ;; is run on it afterwards. (defvar file-coding-system) - (if (and (fboundp 'get-coding-system) - (not (eq file-coding-system + (if (and (vm-xemacs-mule-p) + (not (eq (get-coding-system file-coding-system) (get-coding-system 'no-conversion-unix))) - (not (eq file-coding-system + (not (eq (get-coding-system file-coding-system) (get-coding-system 'no-conversion-dos))) - (not (eq file-coding-system + (not (eq (get-coding-system file-coding-system) (get-coding-system 'no-conversion-mac))) - (not (eq file-coding-system + (not (eq (get-coding-system file-coding-system) (get-coding-system 'binary)))) - (progn - (encode-coding-region (point-min) (point-max) file-coding-system) - (set-file-coding-system 'no-conversion nil) - (decode-coding-region (point-min) (point-max) file-coding-system))) + (let ((buffer-read-only nil) + (omodified (buffer-modified-p))) + (unwind-protect + (progn + (encode-coding-region (point-min) (point-max) + file-coding-system) + (set-file-coding-system 'no-conversion nil) + (decode-coding-region (point-min) (point-max) + 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 @@ -221,7 +227,7 @@ (not vm-block-new-mail) (not vm-folder-read-only)) (progn - (vm-unsaved-message "Checking for new mail for %s..." + (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 @@ -269,7 +275,7 @@ (defun vm-mode (&optional read-only) "Major mode for reading mail. -This is VM 6.15. +This is VM 6.16. Commands: h - summarize folder contents diff -r a0ec055d74dd -r a145efe76779 lisp/vm/vm-summary.el --- a/lisp/vm/vm-summary.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/vm/vm-summary.el Mon Aug 13 09:15:49 2007 +0200 @@ -142,10 +142,10 @@ (vm-set-su-end-of (car mp) (point)) (setq mp (cdr mp) n (1+ n)) (if (zerop (% n modulus)) - (vm-unsaved-message "Generating summary... %d" n))) + (message "Generating summary... %d" n))) ;; now convert the ints to markers. (if (>= n modulus) - (vm-unsaved-message "Generating summary markers... ")) + (message "Generating summary markers... ")) (setq mp m-list) (while mp (and mouse-track-func (funcall mouse-track-func @@ -157,7 +157,7 @@ (set-buffer-modified-p modified)) (run-hooks 'vm-summary-redo-hook))) (if (>= n modulus) - (vm-unsaved-message "Generating summary... done")))) + (message "Generating summary... done")))) (defun vm-do-needed-summary-rebuild () (if (and vm-summary-redo-start-point vm-summary-buffer) @@ -986,7 +986,7 @@ (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) - (vm-unsaved-message "Fixing your summary...") + (message "Fixing your summary...") (let ((mp vm-message-list)) (while mp (vm-set-summary-of (car mp) nil) @@ -995,7 +995,7 @@ (vm-stuff-folder-attributes nil) (set-buffer-modified-p t) (vm-update-summary-and-mode-line)) - (vm-unsaved-message "Fixing your summary... done")) + (message "Fixing your summary... done")) (defun vm-su-thread-indent (m) (if (natnump vm-summary-thread-indent-level) diff -r a0ec055d74dd -r a145efe76779 lisp/vm/vm-thread.el --- a/lisp/vm/vm-thread.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/vm/vm-thread.el Mon Aug 13 09:15:49 2007 +0200 @@ -94,9 +94,9 @@ (aref (symbol-value subject-sym) 2)))))))) (setq mp (cdr mp) n (1+ n)) (if (zerop (% n modulus)) - (vm-unsaved-message "Building threads... %d" n))) + (message "Building threads... %d" n))) (if (> n modulus) - (vm-unsaved-message "Building threads... done")))) + (message "Building threads... done")))) (defun vm-thread-mark-for-summary-update (message-list) (while message-list diff -r a0ec055d74dd -r a145efe76779 lisp/vm/vm-vars.el --- a/lisp/vm/vm-vars.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/vm/vm-vars.el Mon Aug 13 09:15:49 2007 +0200 @@ -1363,7 +1363,6 @@ (defvar vm-resend-bounced-headers '("MIME-Version:" "Content-" - "Resent-" "From:" "Sender:" "Reply-To:" "To:" "Cc:" "Subject:" diff -r a0ec055d74dd -r a145efe76779 lisp/vm/vm-version.el --- a/lisp/vm/vm-version.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/vm/vm-version.el Mon Aug 13 09:15:49 2007 +0200 @@ -2,7 +2,7 @@ (provide 'vm-version) -(defconst vm-version "6.15" +(defconst vm-version "6.16" "Version number of VM.") (defun vm-version () diff -r a0ec055d74dd -r a145efe76779 lisp/vm/vm-virtual.el --- a/lisp/vm/vm-virtual.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/vm/vm-virtual.el Mon Aug 13 09:15:49 2007 +0200 @@ -102,7 +102,9 @@ (find-file-noselect folder))))) (set-buffer (or (and (bufferp folder) folder) (vm-get-file-buffer folder) - (find-file-noselect 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 diff -r a0ec055d74dd -r a145efe76779 lisp/vm/vm-window.el --- a/lisp/vm/vm-window.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/vm/vm-window.el Mon Aug 13 09:15:49 2007 +0200 @@ -132,7 +132,7 @@ (progn (set-buffer (setq work-buffer (get-buffer-create "*vm-wconfig*"))) ;; for XEmacs/MULE - (and (fboundp 'set-file-coding-system) + (and (vm-xemacs-mule-p) (set-file-coding-system 'no-conversion)) (erase-buffer) (print vm-window-configurations (current-buffer)) diff -r a0ec055d74dd -r a145efe76779 lisp/w3/ChangeLog --- a/lisp/w3/ChangeLog Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/w3/ChangeLog Mon Aug 13 09:15:49 2007 +0200 @@ -1,5 +1,130 @@ +Thu Feb 20 13:40:22 1997 William M. Perry + +* w3-forms.el (w3-form-summarize-password): By default, don't summarize + password entry boxes. + +Thu Feb 20 07:33:59 1997 Thierry Emery + +* w3-display.el (w3-frames): Better support for Frames + +Thu Feb 20 07:33:59 1997 William M. Perry + +* w3.el (w3-complete-link): Fixed bug in using try-completion to make sure + we have a match before passing a URL off to w3-fetch. + +* Synch'd up to widget 1.44 + +* url.el (url-default-callback): Caching works in asynch mode now. + +Wed Feb 19 05:48:40 1997 William M. Perry + +* css.el (css-split-font-shorthand): Make sure that the subelements of the + 'font' shorthand property get run through the property value-expansion + routines before getting returned. This royally screwed up font-family, + font-weight, and friends. + (css-expand-color): Now recognizes 'transparent' and 'none' as special + color names. + (css-expand-value): When dealing with color-shorthand, make sure + everything gets run through the value-expansion routines as well. Ack. + +* w3-elisp.el (w3-elisp-safe-function): You can now supply a validation + function for the arguments of a script-enabled function, its no longer a + binary operation on just the function name. You can also give it a + variable name, and the value of that variable at the time of execution + is what controls whether it is safe or not. + +* w3.el (w3-download-url): Finally fixed bug where w3-download-url would + not save in the correct directory if you just accepted the default + pathname it offered. + +* url-cache.el (url-cache-ignored-protocols): New variable controlling + what protocols we should never cache to disk. + (url-cache-cachable-p): use it. + +* w3.txi: Updated all nodes and menus, a few stylistic changes + +* w3-elisp.el: Added read-access to devices, frames, windows, buffers, and + property-lists. Also added function, lambda, point, and list accessors + (member, memq, assoc) + +* w3-display.el (w3-display-node): Bind widget-push-button-gui to nil in + w3-display-node so that images don't run into the + visible-portion-of-buffer-is-not-modifiable-bug. Ick. + +* w3-elisp.el: Don't allow access to 'set'-type text-property functions + from scripts. + +Tue Feb 18 15:11:08 1997 William M. Perry + +* Emacs-W3 3.0.61 released + +* w3.txi (Supported URLs): added sections on each protocol supported - + needs lots of fleshing out. + +* url-misc.el (url-info): Info URL loader now unhex's the target, so that + you can have something like info:w3.info#Getting%20Started + +* url.el (url-do-setup): Removed secure-http (SHTTP) handler - who the + hell cares anymore, it lost. + +* w3-display.el (w3-display-node): Correctly calculates right margin as + documented (from window-width and right-margin) + +* w3.el: Removed w3-batch-fetch + +* url-vars.el: Removed lots of old variables + +* url-misc.el: Removed x-exec URL handler - no interest anymore. + +* w3-script.el (w3-script-evaluate-form): Use it. +(w3-do-scripting): New variable to control whether to do _any_ scripting +or not. + +* The URL package now stores the current parsed URL object instead of 5 or + 6 separate variables. + +* dist.Makefile: Removed old pgp and wais support, it was gross and + apparently nobody was using it. + +Tue Feb 18 06:13:03 1997 "T. V. Raman" + +* w3-forms.el (w3-form-summarize-radio-button): Better radio button + summarizer. + +Tue Feb 18 06:13:03 1997 William M. Perry + +* w3-display.el (w3-finish-drawing): Moved #blah target finding in here, + where it belongs. + +* w3-vars.el (w3-mode-map): Added binding for raw '\t' instead of relying + on [tab]. Apparently this keysym isn't aliased under Emacs 19 on a + TTY. + +Mon Feb 17 15:10:38 1997 William M. Perry + +* w3-elisp.el: Interface to Emacs-Lisp for safe scripting. + +* w3-script.el: Basic client-side scripting has been implemented. + +* w3-xemac.el (w3-mouse-handler): Ditto + +* w3-e19.el (w3-mouse-handler): Plugged in handling of the onMouseOver event + +* w3-display.el (w3-handle-string-content): Now adds a text property that + contains w3-display-open-element-stack, so that from anywhere in the + buffer you can find out where you are in the parse tree. + +* default.css (input): ome default stylesheet updates for input fields on + TTYs + +Sun Feb 16 09:01:18 1997 Shuji Narazaki + +* mule-sysdp.el: Updated for mule 3.0 + Sat Feb 15 15:35:15 1997 William M. Perry +* Emacs-W3 3.0.60 released + * w3-display.el (w3-display-node): use it. * w3-vars.el (w3-display-frames): New variable for whether to show 'frame' diff -r a0ec055d74dd -r a145efe76779 lisp/w3/Makefile --- a/lisp/w3/Makefile Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/w3/Makefile Mon Aug 13 09:15:49 2007 +0200 @@ -35,8 +35,8 @@ URLSOURCES = \ url-nfs.el url-file.el url-cookie.el url-parse.el url-irc.el \ url-gopher.el url-http.el url-mail.el url-misc.el url-news.el \ - url-pgp.el url-vars.el url-wais.el url-auth.el mm.el md5.el \ - url-gw.el ssl.el base64.el url.el socks.el + url-vars.el url-auth.el mm.el md5.el url-gw.el ssl.el base64.el \ + url.el socks.el url-cache.el CUSTOMSOURCES = # widget.el widget-edit.el CUSTOMOBJECTS = $(CUSTOMSOURCES:.el=.elc) @@ -48,7 +48,8 @@ w3-style.el w3-keyword.el w3-forms.el w3-emulate.el \ w3-auto.el w3-menu.el w3-mouse.el w3-toolbar.el w3-prefs.el \ w3-speak.el w3-latex.el w3-parse.el w3-display.el w3-print.el \ - w3-about.el w3-hot.el w3-e19.el w3-xemac.el w3.el + w3-about.el w3-hot.el w3-e19.el w3-xemac.el w3.el w3-script.el \ + w3-jscript.el w3-elisp.el OBJECTS = $(SOURCES:.el=.elc) diff -r a0ec055d74dd -r a145efe76779 lisp/w3/css.el --- a/lisp/w3/css.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/w3/css.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,7 +1,7 @@ ;;; css.el -- Cascading Style Sheet parser ;; Author: wmperry -;; Created: 1997/02/08 05:24:49 -;; Version: 1.27 +;; Created: 1997/02/20 00:47:21 +;; Version: 1.28 ;; Keywords: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -356,10 +356,14 @@ (if (string-match "^[ \t]+" font) (setq family (substring font (match-end 0) nil)) (setq family font))) - (if weight (setq retval (cons (cons 'font-weight weight) retval))) - (if size (setq retval (cons (cons 'font-size size) retval))) - (if height (setq retval (cons (cons 'line-height height) retval))) - (if family (setq retval (cons (cons 'font-family family) retval))) + (if weight + (push (cons 'font-weight (css-expand-value 'weight weight)) retval)) + (if size + (push (cons 'font-size (css-expand-length size)) retval)) + (if height + (push (cons 'line-height (css-expand-length height)) retval)) + (if family + (push (cons 'font-family (css-expand-value 'string-list family)) retval)) retval)) (defun css-expand-length (spec) @@ -404,6 +408,8 @@ (defun css-expand-color (color) (cond + ((string-match "^\\(transparent\\|none\\)$" color) + (setq color nil)) ((string-match "^#" color) (let (r g b) (cond @@ -519,7 +525,7 @@ top center bottom left right) cur) ) (t - (setq color cur)))) + (setq color (css-expand-value 'color cur))))) (setq value (list (cons 'background-color color) (cons 'background-image image) (cons 'background-repeat repeat) @@ -529,10 +535,10 @@ ;; [style | variant | weight]? size[/line-height]? family (setq value (css-split-font-shorthand value))) (border ; width | style | color - ;; FIX + ;; FIXME ) (border-shorthand ; width | style | color - ;; FIX + ;; FIXME ) (list-style ; CSS, Section 5.6.6 ;; keyword | position | url @@ -597,6 +603,7 @@ results ; Assoc list of results name-pos ; Start of XXXX= position val-pos ; Start of value position + (case-fold-search t) ) (save-excursion (if (stringp st) diff -r a0ec055d74dd -r a145efe76779 lisp/w3/docomp.el --- a/lisp/w3/docomp.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/w3/docomp.el Mon Aug 13 09:15:49 2007 +0200 @@ -69,10 +69,6 @@ 'charset-latin-iso8859-1 'file-coding-system-for-read 'file-coding-system) -;; For Mailcrypt -(w3-declare-variables 'mc-pgp-path 'mc-pgp-key-begin-line 'mc-ripem-pubkeyfile - 'mc-default-scheme 'mc-flag) - ;; For NNTP (w3-declare-variables 'nntp-server-buffer 'nntp-server-process 'nntp/connection 'gnus-nntp-server 'nntp-server-name 'nntp-version diff -r a0ec055d74dd -r a145efe76779 lisp/w3/mm.el --- a/lisp/w3/mm.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/w3/mm.el Mon Aug 13 09:15:49 2007 +0200 @@ -173,15 +173,6 @@ ("type" . "application/postscript") ("test" . (not (getenv "DISPLAY"))) ("copiousoutput"))) - ("x-www-pem-reply" . - (("viewer" . (w3-decode-pgp/pem "pem")) - ("test" . (fboundp 'w3-decode-pgp/pem)) - ("type" . "application/x-www-pem-reply") - )) - ("x-www-pgp-reply" . - (("viewer" . (w3-decode-pgp/pem "pgp")) - ("test" . (fboundp 'w3-decode-pgp/pem)) - ("type" . "application/x-www-pgp-reply"))) )) ("audio" . ( ("x-mpeg" . (("viewer" . "maplay %s") diff -r a0ec055d74dd -r a145efe76779 lisp/w3/mule-sysdp.el --- a/lisp/w3/mule-sysdp.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/w3/mule-sysdp.el Mon Aug 13 09:15:49 2007 +0200 @@ -31,14 +31,16 @@ (case mule-sysdep-version (2.3 *euc-japan*) (2.4 'coding-system-euc-japan) + (3.0 'euc-japan) (xemacs 'euc-japan) (otherwise nil)) "Default retrieval coding system for packages that use this package.") (defconst mule-no-coding-system (case mule-sysdep-version + (2.3 *noconv*) (2.4 'no-conversion) - (2.3 *noconv*) + (3.0 'no-conversion) (xemacs 'no-conversion) (otherwise nil)) "Coding system that means no coding system should be used.") @@ -46,8 +48,8 @@ (defun mule-detect-coding-version (st nd) (case mule-sysdep-version (2.3 (code-detect-region (point-min) (point-max))) - (2.4 (detect-coding-region (point-min) (point-max))) - (xemacs (detect-coding-region (point-min) (point-max))) + ((2.4 3.0 xemacs) + (detect-coding-region (point-min) (point-max))) (otherwise nil))) (defun mule-code-convert-region (st nd code) @@ -55,7 +57,7 @@ (setq code (car code))) (case mule-sysdep-version (2.3 - (setq mc-flag t) + (set 'mc-flag t) (code-convert-region (point-min) (point-max) code *internal*) (set-file-coding-system code)) (2.4 @@ -64,6 +66,13 @@ nil (decode-coding-region st nd code) (set-buffer-file-coding-system code))) + (3.0 + (setq enable-multibyte-characters t) + (if (memq code '(autodetect automatic-conversion)) + nil + (or code (setq code 'automatic-conversion)) + (decode-coding-region st nd code) + (set-buffer-file-coding-system code))) (xemacs (if (and (listp code) (not (car code))) (setq code 'autodetect)) @@ -79,7 +88,7 @@ (set 'mc-flag nil) (set 'enable-multibyte-characters nil))) (case mule-sysdep-version - ((2.4 2.3) + ((3.0 2.4 2.3) (set-process-coding-system proc mule-no-coding-system mule-no-coding-system)) (xemacs @@ -101,7 +110,7 @@ (case mule-sysdep-version (2.3 (code-convert-string str *internal* mule-retrieval-coding-system)) - ((2.4 xemacs) + ((2.4 3.0 xemacs) (encode-coding-string str mule-retrieval-coding-system)) (otherwise str))) @@ -109,7 +118,7 @@ (defun mule-decode-string (str) (and str (case mule-sysdep-version - ((2.4 xemacs) + ((2.4 3.0 xemacs) (decode-coding-string str mule-retrieval-coding-system)) (2.3 (code-convert-string str *internal* mule-retrieval-coding-system)) @@ -121,7 +130,7 @@ If width of the truncated string is less than LEN, and if a character PAD is defined, add padding end of it." (case mule-sysdep-version - (2.4 + ((2.4 3.0) (let ((cl (string-to-vector str)) (n 0) (sw 0)) (if (<= (string-width str) len) str (while (<= (setq sw (+ (char-width (aref cl n)) sw)) len) @@ -149,11 +158,12 @@ (case mule-sysdep-version (2.3 (make-character lc-ltn1 char)) (2.4 (make-char charset-latin-iso8859-1 char)) + (3.0 (make-char 'latin-iso8859-1 char)) (xemacs char) (otherwise char)))) (case mule-sysdep-version - ((2.3 2.4 xemacs) nil) + ((2.3 2.4 3.0 xemacs) nil) (otherwise (fset 'string-width 'length))) (and diff -r a0ec055d74dd -r a145efe76779 lisp/w3/url-auth.el --- a/lisp/w3/url-auth.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/w3/url-auth.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,7 +1,7 @@ ;;; url-auth.el --- Uniform Resource Locator authorization modules ;; Author: wmperry -;; Created: 1997/01/19 01:17:29 -;; Version: 1.5 +;; Created: 1997/02/18 23:34:14 +;; Version: 1.6 ;; Keywords: comm, data, processes, hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -54,7 +54,7 @@ (let* ((href (if (stringp url) (url-generic-parse-url url) url)) - (server (or (url-host href) url-current-server)) + (server (url-host href)) (port (or (url-port href) "80")) (path (url-filename href)) user pass byserv retval data) @@ -134,7 +134,7 @@ (let* ((href (if (stringp url) (url-generic-parse-url url) url)) - (server (or (url-host href) url-current-server)) + (server (url-host href)) (port (or (url-port href) "80")) (path (url-filename href)) user pass byserv retval data) diff -r a0ec055d74dd -r a145efe76779 lisp/w3/url-cache.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/w3/url-cache.el Mon Aug 13 09:15:49 2007 +0200 @@ -0,0 +1,317 @@ +;;; url-cache.el --- Uniform Resource Locator retrieval tool +;; Author: wmperry +;; Created: 1997/02/20 15:33:47 +;; Version: 1.3 +;; Keywords: comm, data, processes, hypermedia + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Copyright (c) 1993-1996 by William M. Perry (wmperry@cs.indiana.edu) +;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc. +;;; +;;; This file is not part of GNU Emacs, but the same permissions apply. +;;; +;;; 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. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(require 'md5) + +;; Cache manager +(defun url-cache-file-writable-p (file) + "Follows the documentation of file-writable-p, unlike file-writable-p." + (and (file-writable-p file) + (if (file-exists-p file) + (not (file-directory-p file)) + (file-directory-p (file-name-directory file))))) + +(defun url-prepare-cache-for-file (file) + "Makes it possible to cache data in FILE. +Creates any necessary parent directories, deleting any non-directory files +that would stop this. Returns nil if parent directories can not be +created. If FILE already exists as a non-directory, it changes +permissions of FILE or deletes FILE to make it possible to write a new +version of FILE. Returns nil if this can not be done. Returns nil if +FILE already exists as a directory. Otherwise, returns t, indicating that +FILE can be created or overwritten." + + ;; COMMENT: We don't delete directories because that requires + ;; recursively deleting the directories's contents, which might + ;; eliminate a substantial portion of the cache. + + (cond + ((url-cache-file-writable-p file) + t) + ((file-directory-p file) + nil) + (t + (catch 'upcff-tag + (let ((dir (file-name-directory file)) + dir-parent dir-last-component) + (if (string-equal dir file) + ;; *** Should I have a warning here? + ;; FILE must match a pattern like /foo/bar/, indicating it is a + ;; name only suitable for a directory. So presume we won't be + ;; able to overwrite FILE and return nil. + (throw 'upcff-tag nil)) + + ;; Make sure the containing directory exists, or throw a failure + ;; if we can't create it. + (if (file-directory-p dir) + nil + (or (fboundp 'make-directory) + (throw 'upcff-tag nil)) + (make-directory dir t) + ;; make-directory silently fails if there is an obstacle, so + ;; we must verify its results. + (if (file-directory-p dir) + nil + ;; Look at prefixes of the path to find the obstacle that is + ;; stopping us from making the directory. Unfortunately, there + ;; is no portable function in Emacs to find the parent directory + ;; of a *directory*. So this code may not work on VMS. + (while (progn + (if (eq ?/ (aref dir (1- (length dir)))) + (setq dir (substring dir 0 -1)) + ;; Maybe we're on VMS where the syntax is different. + (throw 'upcff-tag nil)) + (setq dir-parent (file-name-directory dir)) + (not (file-directory-p dir-parent))) + (setq dir dir-parent)) + ;; We have found the longest path prefix that exists as a + ;; directory. Deal with any obstacles in this directory. + (if (file-exists-p dir) + (condition-case nil + (delete-file dir) + (error (throw 'upcff-tag nil)))) + (if (file-exists-p dir) + (throw 'upcff-tag nil)) + ;; Try making the directory again. + (setq dir (file-name-directory file)) + (make-directory dir t) + (or (file-directory-p dir) + (throw 'upcff-tag nil)))) + + ;; The containing directory exists. Let's see if there is + ;; something in the way in this directory. + (if (url-cache-file-writable-p file) + (throw 'upcff-tag t) + (condition-case nil + (delete-file file) + (error (throw 'upcff-tag nil)))) + + ;; The return value, if we get this far. + (url-cache-file-writable-p file)))))) + +(defvar url-cache-ignored-protocols + '("www" "about" "https" "mailto") + "*A list of protocols that we should never cache.") + +(defun url-cache-cachable-p (obj) + ;; return t iff the current buffer is cachable + (cond + ((null obj) ; Something horribly confused + nil) + ((member (url-type obj) url-cache-ignored-protocols) + ;; We have been told to ignore this type of object + nil) + ((and (member (url-type obj) '("file" "ftp")) (not (url-host obj))) + ;; We never want to cache local files... what's the point? + nil) + ((member (url-type obj) '("http" "https")) + (let* ((status (cdr-safe (assoc "status" url-current-mime-headers))) + (class (if status (/ status 100) 0))) + (case class + (2 ; Various 'OK' statuses + (memq status '(200))) + (otherwise nil)))) + (t + nil))) + +;;;###autoload +(defun url-store-in-cache (&optional buff) + "Store buffer BUFF in the cache" + (if (and buff (get-buffer buff)) + nil + (save-excursion + (and buff (set-buffer buff)) + (if (not (url-cache-cachable-p url-current-object)) + nil + (let* ((fname (url-create-cached-filename (url-view-url t))) + (fname-hdr (concat fname ".hdr")) + (info (mapcar (function (lambda (var) + (cons (symbol-name var) + (symbol-value var)))) + '( url-current-content-length + url-current-object + url-current-isindex + url-current-mime-encoding + url-current-mime-headers + url-current-mime-type + )))) + (cond ((and (url-prepare-cache-for-file fname) + (url-prepare-cache-for-file fname-hdr)) + (write-region (point-min) (point-max) fname nil 5) + (set-buffer (get-buffer-create " *cache-tmp*")) + (erase-buffer) + (insert "(setq ") + (mapcar + (function + (lambda (x) + (insert (car x) " " + (cond ((null (setq x (cdr x))) "nil") + ((stringp x) (prin1-to-string x)) + ((listp x) (concat "'" (prin1-to-string x))) + ((vectorp x) (prin1-to-string x)) + ((numberp x) (int-to-string x)) + (t "'???")) "\n"))) + info) + (insert ")\n") + (write-region (point-min) (point-max) fname-hdr nil 5)))))))) + + +;;;###autoload +(defun url-is-cached (url) + "Return non-nil if the URL is cached." + (let* ((fname (url-create-cached-filename url)) + (attribs (file-attributes fname))) + (and fname ; got a filename + (file-exists-p fname) ; file exists + (not (eq (nth 0 attribs) t)) ; Its not a directory + (nth 5 attribs)))) ; Can get last mod-time + +(defun url-create-cached-filename-using-md5 (url) + (if url + (expand-file-name (md5 url) + (concat url-temporary-directory "/" + (user-real-login-name))))) + +;;;###autoload +(defun url-create-cached-filename (url) + "Return a filename in the local cache for URL" + (if url + (let* ((url url) + (urlobj (if (vectorp url) + url + (url-generic-parse-url url))) + (protocol (url-type urlobj)) + (hostname (url-host urlobj)) + (host-components + (cons + (user-real-login-name) + (cons (or protocol "file") + (nreverse + (delq nil + (mm-string-to-tokens + (or hostname "localhost") ?.)))))) + (fname (url-filename urlobj))) + (if (and fname (/= (length fname) 0) (= (aref fname 0) ?/)) + (setq fname (substring fname 1 nil))) + (if fname + (let ((slash nil)) + (setq fname + (mapconcat + (function + (lambda (x) + (cond + ((and (= ?/ x) slash) + (setq slash nil) + "%2F") + ((= ?/ x) + (setq slash t) + "/") + (t + (setq slash nil) + (char-to-string x))))) fname "")))) + + (if (and fname (memq system-type '(ms-windows ms-dos windows-nt)) + (string-match "\\([A-Za-z]\\):[/\\]" fname)) + (setq fname (concat (url-match fname 1) "/" + (substring fname (match-end 0))))) + + (setq fname (and fname + (mapconcat + (function (lambda (x) + (if (= x ?~) "" (char-to-string x)))) + fname "")) + fname (cond + ((null fname) nil) + ((or (string= "" fname) (string= "/" fname)) + url-directory-index-file) + ((= (string-to-char fname) ?/) + (if (string= (substring fname -1 nil) "/") + (concat fname url-directory-index-file) + (substring fname 1 nil))) + (t + (if (string= (substring fname -1 nil) "/") + (concat fname url-directory-index-file) + fname)))) + + ;; Honor hideous 8.3 filename limitations on dos and windows + ;; we don't have to worry about this in Windows NT/95 (or OS/2?) + (if (and fname (memq system-type '(ms-windows ms-dos))) + (let ((base (url-file-extension fname t)) + (ext (url-file-extension fname nil))) + (setq fname (concat (substring base 0 (min 8 (length base))) + (substring ext 0 (min 4 (length ext))))) + (setq host-components + (mapcar + (function + (lambda (x) + (if (> (length x) 8) + (concat + (substring x 0 8) "." + (substring x 8 (min (length x) 11))) + x))) + host-components)))) + + (and fname + (expand-file-name fname + (expand-file-name + (mapconcat 'identity host-components "/") + url-temporary-directory)))))) + +;;;###autoload +(defun url-extract-from-cache (fnam) + "Extract FNAM from the local disk cache" + (set-buffer (get-buffer-create url-working-buffer)) + (erase-buffer) + (setq url-current-mime-viewer nil) + (insert-file-contents-literally fnam) + (load (concat (if (memq system-type '(ms-windows ms-dos os2)) + (url-file-extension fnam t) + fnam) ".hdr") t t)) + +;;;###autoload +(defun url-cache-expired (url mod) + "Return t iff a cached file has expired." + (if (not (string-match url-nonrelative-link url)) + t + (let* ((urlobj (url-generic-parse-url url)) + (type (url-type urlobj))) + (cond + (url-standalone-mode + (not (file-exists-p (url-create-cached-filename urlobj)))) + ((string= type "http") + (if (not url-standalone-mode) t + (not (file-exists-p (url-create-cached-filename urlobj))))) + ((not (fboundp 'current-time)) + t) + ((member type '("file" "ftp")) + (if (or (equal mod '(0 0)) (not mod)) + (return t) + (or (> (nth 0 mod) (nth 0 (current-time))) + (> (nth 1 mod) (nth 1 (current-time)))))) + (t nil))))) + +(provide 'url-cache) diff -r a0ec055d74dd -r a145efe76779 lisp/w3/url-cookie.el --- a/lisp/w3/url-cookie.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/w3/url-cookie.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,7 +1,7 @@ ;;; url-cookie.el --- Netscape Cookie support ;; Author: wmperry -;; Created: 1997/01/26 00:40:23 -;; Version: 1.10 +;; Created: 1997/02/18 23:34:20 +;; Version: 1.11 ;; Keywords: comm, data, processes, hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -297,12 +297,13 @@ (secure (and (assoc* "secure" args :test 'url-header-comparison) t)) (domain (or (cdr-safe (assoc* "domain" args :test 'url-header-comparison)) - url-current-server)) + (url-host url-current-object))) (expires (cdr-safe (assoc* "expires" args :test 'url-header-comparison))) (path (or (cdr-safe (assoc* "path" args :test 'url-header-comparison)) - (file-name-directory url-current-file))) + (file-name-directory + (url-filename url-current-object)))) (rest nil)) (while args (if (not (member (downcase (car (car args))) @@ -330,10 +331,10 @@ ((and url-cookie-confirmation (not (funcall url-confirmation-func (format "Allow %s to set a cookie? " - url-current-server)))) + (url-host url-current-object))))) ;; user wants to be asked, and declined. nil) - ((url-cookie-host-can-set-p url-current-server domain) + ((url-cookie-host-can-set-p (url-host url-current-object) domain) ;; Cookie is accepted by the user, and passes our security checks (let ((cur nil)) (while rest @@ -351,6 +352,6 @@ (concat "%s tried to set a cookie for domain %s\n" "Permission denied - cookie rejected.\n" "Set-Cookie: %s") - url-current-server domain str)))))) + (url-host url-current-object) domain str)))))) (provide 'url-cookie) diff -r a0ec055d74dd -r a145efe76779 lisp/w3/url-file.el --- a/lisp/w3/url-file.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/w3/url-file.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,7 +1,7 @@ ;;; url-file.el --- File retrieval code ;; Author: wmperry -;; Created: 1997/02/10 16:16:46 -;; Version: 1.13 +;; Created: 1997/02/19 23:38:31 +;; Version: 1.15 ;; Keywords: comm, data, processes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -136,82 +136,6 @@ (kill-buffer (current-buffer)) (find-file dir) (url-dired-minor-mode t))) -; (let ((files (directory-files dir nil)) file -; div attr mod-time size typ title desc) -; (save-excursion -; (if (string-match "/\\([^/]+\\)/$" dir) -; (setq title (concat ".../" (url-match dir 1) "/")) -; (setq title "/")) -; (setq div (1- (length files))) -; (set-buffer url-working-buffer) -; (erase-buffer) -; (insert "\n" -; " \n" -; " " title "\n" -; " \n" -; " \n" -; "

Index of " title "

\n" -; " \n" -; " \n" -; " \n") -; (while files -; (url-lazy-message "Building directory list... (%d%%)" -; (/ (* 100 (- div (length files))) div)) -; (setq file (expand-file-name (car files) dir) -; attr (file-attributes file) -; file (car files) -; mod-time (nth 5 attr) -; size (nth 7 attr) -; typ (or (mm-extension-to-mime (url-file-extension file)) "")) -; (setq file (url-hexify-string file)) -; (if (equal '(0 0) mod-time) ; Set to null if unknown or -; (setq mod-time "Unknown") -; (setq mod-time (current-time-string mod-time))) -; (if (or (equal size 0) (equal size -1) (null size)) -; (setq size "-") -; (setq size -; (cond -; ((< size 1024) "1K") -; ((< size 1048576) (concat (int-to-string -; (max 1 (/ size 1024))) "K")) -; (t -; (let* ((megs (max 1 (/ size 1048576))) -; (kilo (/ (- size (* megs 1048576)) 1024))) -; (concat (int-to-string megs) -; (if (> kilo 0) -; (concat "." (int-to-string kilo)) -; "") "M")))))) -; (cond -; ((or (equal "." (car files)) -; (equal "/.." (car files))) -; (setq desc nil)) -; ((equal ".." (car files)) -; (if (not (= ?/ (aref file (1- (length file))))) -; (setq file (concat file "/")))) -; ((stringp (nth 0 attr)) ; Symbolic link handling -; (setq desc "[LNK]")) -; ((nth 0 attr) ; Directory handling -; (setq desc "[DIR]")) -; ((string-match "image" typ) -; (setq desc "[IMG]")) -; ((string-match "application" typ) -; (setq desc "[APP]")) -; ((string-match "text" typ) -; (setq desc "[TXT]")) -; ((auto-save-file-name-p (car files)) -; (setq desc "[BAK]")) -; (t -; (setq desc "[UNK]"))) -; (if desc -; (insert "\n")) -; (setq files (cdr files))) -; (insert "
NameLast ModifiedSize
" desc " " (car files) -; "" mod-time "

" size -; "

\n" -; " \n" -; "\n" -; "\n"))) (defun url-host-is-local-p (host) "Return t iff HOST references our local machine." @@ -240,15 +164,6 @@ (concat "/" (or user "anonymous") "@" site ":" file) file))) - (if (and file (url-host-is-local-p site) - (memq system-type '(ms-windows ms-dos windows-nt os2))) - (let ((x (1- (length file))) - (y 0)) - (while (<= y x) - (if (= (aref file y) ?\\ ) - (aset file y ?/)) - (setq y (1+ y))))) - (url-clear-tmp-buffer) (and user pass (cond @@ -315,14 +230,8 @@ (error (url-save-error errobj) (url-retrieve (concat "www://error/nofile/" file)))))))) - (setq url-current-type (if site "ftp" "file") - url-current-object urlobj - url-find-this-link dest - url-current-user user - url-current-server site - url-current-mime-type (mm-extension-to-mime - (url-file-extension file)) - url-current-file file))) + (setq url-current-mime-type (mm-extension-to-mime + (url-file-extension file))))) (fset 'url-ftp 'url-file) diff -r a0ec055d74dd -r a145efe76779 lisp/w3/url-gopher.el --- a/lisp/w3/url-gopher.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/w3/url-gopher.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,7 +1,7 @@ ;;; url-gopher.el --- Gopher Uniform Resource Locator retrieval code ;; Author: wmperry -;; Created: 1997/02/08 05:25:58 -;; Version: 1.5 +;; Created: 1997/02/18 23:34:30 +;; Version: 1.6 ;; Keywords: comm, data, processes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -244,14 +244,14 @@ (erase-buffer) (insert "" (cond - ((or (string= "" url-current-file) - (string= "1/" url-current-file) - (string= "1" url-current-file)) - (concat "Gopher root at " url-current-server)) + ((or (string= "" (url-filename url-current-object)) + (string= "1/" (url-filename url-current-object)) + (string= "1" (url-filename url-current-object))) + (concat "Gopher root at " (url-host url-current-object))) ((string-match (format "^[%s]+/" url-gopher-types) - url-current-file) - (substring url-current-file 2 nil)) - (t url-current-file)) + (url-filename url-current-object)) + (substring (url-filename url-current-object) 2 nil)) + (t (url-filename url-current-object))) "
    " (mapconcat 'url-format-gopher-link objs "") "
")))) @@ -264,10 +264,6 @@ (len nil) (parsed nil)) (url-clear-tmp-buffer) - (setq url-current-file selector - url-current-port port - url-current-server host - url-current-type "gopher") (if (> (length selector) 0) (setq selector (substring selector 1 nil))) (if (not (processp proc)) @@ -447,11 +443,7 @@ (setq type "text/html" url-current-mime-viewer (mm-mime-info type nil 5)))) (setq url-current-mime-type (or type "text/plain") - url-current-mime-viewer (mm-mime-info type nil 5) - url-current-file file - url-current-port port - url-current-server host - url-current-type "gopher"))) + url-current-mime-viewer (mm-mime-info type nil 5)))) (defun url-gopher (url) ;; Handle gopher URLs diff -r a0ec055d74dd -r a145efe76779 lisp/w3/url-http.el --- a/lisp/w3/url-http.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/w3/url-http.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,7 +1,7 @@ ;;; url-http.el --- HTTP Uniform Resource Locator retrieval code ;; Author: wmperry -;; Created: 1997/02/08 05:29:12 -;; Version: 1.13 +;; Created: 1997/02/19 00:50:08 +;; Version: 1.15 ;; Keywords: comm, data, processes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -137,7 +137,7 @@ (url-generic-parse-url proxy-info))) (real-fname (if proxy-obj (url-filename proxy-obj) fname)) (host (or (and proxy-obj (url-host proxy-obj)) - url-current-server)) + (url-host url-current-object))) (auth (if (cdr-safe (assoc "Authorization" url-request-extra-headers)) nil (url-get-authentication (or @@ -197,10 +197,8 @@ url-mime-accept-string (url-http-user-agent-string) (or auth "") - (url-cookie-generate-header-lines host - real-fname - (string-match "https" - url-current-type)) + (url-cookie-generate-header-lines + host real-fname (equal "https" (url-type url-current-object))) (or proxy-auth "") (if (and (not no-cache) (member url-request-method '("GET" nil))) @@ -415,11 +413,6 @@ (substring y 0 (match-beginning 0)) y)))) (cond - ((or (equal "pem" type) (equal "pgp" type)) - (if (string-match "entity=\"\\([^\"]+\\)\"" y) - (url-fetch-with-pgp url-current-file - (url-match y 1) (intern type)) - (error "Could not find entity in %s!" type))) ((url-auth-registered type) (let ((args y) (ctr (1- (length y))) @@ -454,11 +447,6 @@ (substring y 0 (match-beginning 0)) y)))) (cond - ((or (equal "pem" type) (equal "pgp" type)) - (if (string-match "entity=\"\\([^\"]+\\)\"" y) - (url-fetch-with-pgp url-current-file - (url-match y 1) (intern type)) - (error "Could not find entity in %s!" type))) ((url-auth-registered type) (let ((args y) (ctr (1- (length y))) @@ -540,8 +528,6 @@ (let* ((urlobj (url-generic-parse-url url)) (ref-url (or url-current-referer (url-view-url t)))) (url-clear-tmp-buffer) - (setq url-current-type (if (boundp 'url-this-is-ssl) - "https" "http")) (let* ((server (url-host urlobj)) (port (url-port urlobj)) (file (or proxy-info (url-recreate-with-attributes urlobj))) @@ -560,18 +546,6 @@ "way, or an incorrect URL was manually entered (more likely)." ))) (error "Malformed URL: `%s'" url))) - (if proxy-info - (let ((x (url-generic-parse-url url))) - (setq url-current-server (url-host urlobj) - url-current-port (url-port urlobj) - url-current-file (url-filename urlobj) - url-find-this-link (url-target urlobj) - request (url-create-mime-request file ref-url))) - (setq url-current-server server - url-current-port port - url-current-file file - url-find-this-link dest - request (url-create-mime-request file ref-url))) (if (or (not (member port url-bad-port-list)) (funcall url-confirmation-func (concat @@ -579,6 +553,7 @@ port " - continue? "))) (progn + (setq request (url-create-mime-request file ref-url)) (url-lazy-message "Contacting %s:%s" server port) (let ((process (url-open-stream "WWW" url-working-buffer server @@ -613,10 +588,6 @@ (ding) (url-warn 'security "Aborting connection to bad port...")))))) -(defun url-shttp (url) - ;; Retrieve a URL via Secure-HTTP - (error "Secure-HTTP not implemented yet.")) - (defun url-https (url) ;; Retrieve a URL via SSL (condition-case () diff -r a0ec055d74dd -r a145efe76779 lisp/w3/url-misc.el --- a/lisp/w3/url-misc.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/w3/url-misc.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,7 +1,7 @@ ;;; url-misc.el --- Misc Uniform Resource Locator retrieval code ;; Author: wmperry -;; Created: 1997/02/08 05:29:22 -;; Version: 1.10 +;; Created: 1997/02/19 00:52:07 +;; Version: 1.12 ;; Keywords: comm, data, processes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -36,7 +36,7 @@ (kill-buffer url-working-buffer)) (let* ((data (url-generic-parse-url url)) (fname (url-filename data)) - (node (or (url-target data) "Top"))) + (node (url-unhex-string (or (url-target data) "Top")))) (if (and fname node) (Info-goto-node (concat "(" fname ")" node)) (error "Malformed url: %s" url)))) @@ -126,84 +126,7 @@ (let ( (urlobj (url-generic-parse-url url)) (proxyobj (url-generic-parse-url url-using-proxy))) - (url-http url-using-proxy url) - (setq url-current-type (url-type urlobj) - url-current-user (url-user urlobj) - url-current-port (or (url-port urlobj) - (cdr-safe (assoc url-current-type - url-default-ports))) - url-current-server (url-host urlobj) - url-current-file (url-filename urlobj)))) - -(defun url-x-exec (url) - ;; Handle local execution of scripts. - (set-buffer (get-buffer-create url-working-buffer)) - (erase-buffer) - (string-match "x-exec:/+\\([^/]+\\)\\(/.*\\)" url) - (let ((process-environment process-environment) - (executable (url-match url 1)) - (path-info (url-match url 2)) - (query-string nil) - (safe-paths url-local-exec-path) - (found nil) - (y nil) - ) - (setq url-current-server executable - url-current-file path-info) - (if (string-match "\\(.*\\)\\?\\(.*\\)" path-info) - (setq query-string (url-match path-info 2) - path-info (url-match path-info 1))) - (while (and safe-paths (not found)) - (setq y (expand-file-name executable (car safe-paths)) - found (and (file-exists-p y) (file-executable-p y) y) - safe-paths (cdr safe-paths))) - (if (not found) - (url-retrieve (concat "www://error/nofile/" executable)) - (setq process-environment - (append - (list - "SERVER_SOFTWARE=x-exec/1.0" - (concat "SERVER_NAME=" (system-name)) - "GATEWAY_INTERFACE=CGI/1.1" - "SERVER_PROTOCOL=HTTP/1.0" - "SERVER_PORT=" - (concat "REQUEST_METHOD=" url-request-method) - (concat "HTTP_ACCEPT=" - (mapconcat - (function - (lambda (x) - (cond - ((= x ?\n) (setq y t) "") - ((= x ?:) (setq y nil) ",") - (t (char-to-string x))))) url-mime-accept-string - "")) - (concat "PATH_INFO=" (url-unhex-string path-info)) - (concat "PATH_TRANSLATED=" (url-unhex-string path-info)) - (concat "SCRIPT_NAME=" executable) - (concat "QUERY_STRING=" (url-unhex-string query-string)) - (concat "REMOTE_HOST=" (system-name))) - (if (assoc "content-type" url-request-extra-headers) - (concat "CONTENT_TYPE=" (cdr - (assoc "content-type" - url-request-extra-headers)))) - (if url-request-data - (concat "CONTENT_LENGTH=" (length url-request-data))) - process-environment)) - (and url-request-data (insert url-request-data)) - (setq y (call-process-region (point-min) (point-max) found t t)) - (goto-char (point-min)) - (delete-region (point) (progn (skip-chars-forward " \t\n") (point))) - (cond - ((url-mime-response-p) nil) ; Its already got an HTTP/1.0 header - ((null y) ; Weird exit status, whassup? - (insert "HTTP/1.0 404 Not Found\n" - "Server: " url-package-name "/x-exec\n")) - ((= 0 y) ; The shell command was successful - (insert "HTTP/1.0 200 Document follows\n" - "Server: " url-package-name "/x-exec\n")) - (t ; Non-zero exit status is bad bad bad - (insert "HTTP/1.0 404 Not Found\n" - "Server: " url-package-name "/x-exec\n")))))) + (url-http url-using-proxy url))) ;; ftp://ietf.org/internet-drafts/draft-masinter-url-data-02.txt (defun url-data (url) diff -r a0ec055d74dd -r a145efe76779 lisp/w3/url-news.el --- a/lisp/w3/url-news.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/w3/url-news.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,7 +1,7 @@ ;;; url-news.el --- News Uniform Resource Locator retrieval code ;; Author: wmperry -;; Created: 1997/01/10 00:13:05 -;; Version: 1.6 +;; Created: 1997/02/18 23:35:11 +;; Version: 1.7 ;; Keywords: comm, data, processes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -60,8 +60,6 @@ "") "[ \t,\n<>]+"))))) (date (cdr (assoc "date" url-current-mime-headers)))) - (setq url-current-file "" - url-current-type "") (if (or (not (string-match "text/" typ)) (string-match "text/html" typ)) nil ; Let natural content-type take over @@ -253,12 +251,7 @@ (gnus) (kill-buffer url-working-buffer)) (t ; Whole newsgroup - (url-news-fetch-newsgroup article host))) - (setq url-current-type "news" - url-current-server host - url-current-user (url-user urlobj) - url-current-port port - url-current-file article))) + (url-news-fetch-newsgroup article host))))) (defun url-nntp (url) ;; Find a news reference @@ -282,11 +275,6 @@ (gnus) (kill-buffer url-working-buffer)) (t ; Whole newsgroup - (url-news-fetch-newsgroup article))) - (setq url-current-type "news" - url-current-server host - url-current-user (url-user urlobj) - url-current-port port - url-current-file article))) + (url-news-fetch-newsgroup article))))) (provide 'url-news) diff -r a0ec055d74dd -r a145efe76779 lisp/w3/url-pgp.el --- a/lisp/w3/url-pgp.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/w3/url-pgp.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,175 +0,0 @@ -;;; url-pgp.el --- PGP encapsulation of HTTP -;; Author: wmperry -;; Created: 1997/01/10 00:13:05 -;; Version: 1.3 -;; Keywords: comm, data, processes - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Copyright (c) 1993-1996 by William M. Perry (wmperry@cs.indiana.edu) -;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc. -;;; -;;; This file is not part of GNU Emacs, but the same permissions apply. -;;; -;;; 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. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(require 'url-vars) -(require 'url-parse) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; UUencoding -;;; ---------- -;;; These functions are needed for the (RI)PEM encoding. PGP can -;;; handle binary data, but (RI)PEM requires that it be uuencoded -;;; first, or it will barf severely. How rude. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun url-uuencode-buffer (&optional buff) - "UUencode buffer BUFF, with a default of the current buffer." - (setq buff (or buff (current-buffer))) - (save-excursion - (set-buffer buff) - (url-lazy-message "UUencoding...") - (call-process-region (point-min) (point-max) - url-uuencode-program t t nil "url-temp-file") - (url-lazy-message "UUencoding... done."))) - -(defun url-uudecode-buffer (&optional buff) - "UUdecode buffer BUFF, with a default of the current buffer." - (setq buff (or buff (current-buffer))) - (let ((newname (url-generate-unique-filename))) - (save-excursion - (set-buffer buff) - (goto-char (point-min)) - (re-search-forward "^begin [0-9][0-9][0-9] \\(.*\\)$" nil t) - (replace-match (concat "begin 600 " newname)) - (url-lazy-message "UUdecoding...") - (call-process-region (point-min) (point-max) url-uudecode-program) - (url-lazy-message "UUdecoding...") - (erase-buffer) - (insert-file-contents-literally newname) - (url-lazy-message "UUdecoding... done.") - (condition-case () - (delete-file newname) - (error nil))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Decoding PGP/PEM responses -;;; -------------------------- -;;; A PGP/PEM encrypted/signed response contains all the real headers, -;;; so this is just a quick decrypt-then-reparse hack. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun url-decode-pgp/pem (arg) - "Decode a pgp/pem response from an HTTP/1.0 server. -This expects the decoded message to contain all the necessary HTTP/1.0 headers -to correctly act on the decoded message (new content-type, etc)." - (mc-decrypt-message) - (url-parse-mime-headers)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; PGP/PEM Encryption -;;; ------------------ -;;; This implements the highly secure PGP/PEM encrypted requests, as -;;; specified by NCSA and CERN. -;;; -;;; The complete online spec of this scheme was done by Tony Sanders -;;; , and can be seen at -;;; http://www.bsdi.com/HTTP:TNG/ripem-http.txt -;;; -;;; This section of code makes use of the EXCELLENT mailcrypt.el -;;; package by Jin S Choi (jsc@mit.edu) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun url-public-key-exists (entity scheme) - "Return t iff a key for ENTITY exists using public key system SCHEME. -ENTITY is the username/hostname combination we are checking for. -SCHEME is a symbol representing what public key encryption program to use. - Currently only 'pgp (Pretty Good Privacy) and 'pem (RIPEM) are - recognized." - (let (retval) - (save-excursion - (cond - ((eq 'pgp scheme) ; PGP encryption - (set-buffer (get-buffer-create " *keytmp*")) - (erase-buffer) - (call-process mc-pgp-path nil t nil "+batchmode" "-kxaf" entity) - (goto-char (point-min)) - (setq retval (search-forward mc-pgp-key-begin-line nil t))) - ((eq 'pem scheme) ; PEM encryption - (set-buffer (find-file-noselect mc-ripem-pubkeyfile)) - (goto-char (point-min)) - (setq retval (search-forward entity nil t))) - (t - (url-warn 'security - (format - "Bad value for SCHEME in url-public-key-exists %s" - scheme)))) - (kill-buffer (current-buffer))) - retval)) - -(defun url-get-server-keys (entity &optional scheme) - "Make sure the key for ENTITY exists using SCHEME. -ENTITY is the username/hostname combination to get the info for. - This should be a string you could pass to 'finger'. -SCHEME is a symbol representing what public key encryption program to use. - Currently only 'pgp (Pretty Good Privacy) and 'pem (RIPEM) are - recognized." - (or scheme (setq scheme mc-default-scheme)) - (save-excursion - (cond - ((url-public-key-exists entity scheme) nil) - (t - (string-match "\\([^@]+\\)@\\(.*\\)" entity) - (let ((url-working-buffer " *url-get-keys*")) - (url-retrieve (format "gopher://%s:79/0%s/w" (url-match entity 1) - (url-match entity 2))) - (mc-snarf-keys) - (kill-buffer url-working-buffer)))))) - -(defun url-fetch-with-pgp (url recipient type) - "Retrieve a document with public-key authentication. - URL is the url to request from the server. -RECIPIENT is the server's entity name (usually webmaster@host) - TYPE is a symbol representing what public key encryption program to use. - Currently only 'pgp (Pretty Good Privacy) and 'pem (RIPEM) are - recognized." - (or noninteractive (require 'mailcrypt)) - (let ((request (url-create-mime-request url "PGP-Redirect")) - (url-request-data nil) - (url-request-extra-headers nil)) - (save-excursion - (url-get-server-keys recipient type) - (set-buffer (get-buffer-create " *url-encryption*")) - (erase-buffer) - (insert "\n\n" mail-header-separator "\n" request) - (mc-encrypt-message recipient type) - (goto-char (point-min)) - (if (re-search-forward (concat "\n" mail-header-separator "\n") nil t) - (delete-region (point-min) (point))) - (setq url-request-data (buffer-string) - url-request-extra-headers - (list (cons "Authorized" (format "%s entity=\"%s\"" - (cond - ((eq type 'pgp) "PGP") - ((eq type 'pem) "PEM")) - url-pgp/pem-entity)) - (cons "Content-type" (format "application/x-www-%s-reply" - (cond - ((eq type 'pgp) "pgp") - ((eq type 'pem) "pem"))))))) - (kill-buffer " *url-encryption*") - (url-retrieve (url-expand-file-name "/") t))) - -(provide 'url-pgp) diff -r a0ec055d74dd -r a145efe76779 lisp/w3/url-vars.el --- a/lisp/w3/url-vars.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/w3/url-vars.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,7 +1,7 @@ ;;; url-vars.el --- Variables for Uniform Resource Locator tool ;; Author: wmperry -;; Created: 1997/02/10 16:15:19 -;; Version: 1.27 +;; Created: 1997/02/18 23:35:21 +;; Version: 1.28 ;; Keywords: comm, data, processes, hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -50,18 +50,20 @@ url-current-callback-func url-current-can-be-cached url-current-content-length - url-current-file url-current-isindex url-current-mime-encoding url-current-mime-headers url-current-mime-type url-current-mime-viewer url-current-object - url-current-port url-current-referer - url-current-server - url-current-type - url-current-user + + ;; obsolete + ;; url-current-file + ;; url-current-port + ;; url-current-server + ;; url-current-type + ;; url-current-user )) (defvar url-cookie-storage nil "Where cookies are stored.") @@ -78,16 +80,6 @@ If t, all refresh requests will be honored. If non-nil and not t, the user will be asked for each refresh request.") -(defvar url-emacs-minor-version - (if (boundp 'emacs-minor-version) - (symbol-value 'emacs-minor-version) - (if (string-match "^[0-9]+\\.\\([0-9]+\\)" emacs-version) - (string-to-int - (substring emacs-version - (match-beginning 1) (match-end 1))) - 0)) - "What minor version of emacs we are using.") - (defvar url-inhibit-mime-parsing nil "Whether to parse out (and delete) the MIME headers from a message.") @@ -101,30 +93,22 @@ returns non-nil if the second time is 'too old' when compared to the first time.") -(defvar url-check-md5s nil - "*Whether to check md5s of retrieved documents or not.") - -(defvar url-expected-md5 nil "What md5 we expect to see.") - -(defvar url-bug-address "wmperry@cs.indiana.edu" "Where to send bug reports.") +(defvar url-bug-address "wmperry@cs.indiana.edu" + "Where to send bug reports.") (defvar url-cookie-confirmation nil - "*If non-nil, confirmation by the user is required before accepting any -HTTP cookies.") + "*If non-nil, confirmation by the user is required to accept HTTP cookies.") (defvar url-personal-mail-address nil - "*Your full email address. This is what is sent to HTTP/1.0 servers as -the FROM field. If not set when url-do-setup is run, it defaults to -the value of url-pgp/pem-entity.") + "*Your full email address. +This is what is sent to HTTP/1.0 servers as the FROM field in an HTTP/1.0 +request.") (defvar url-directory-index-file "index.html" "*The filename to look for when indexing a directory. If this file exists, and is readable, then it will be viewed instead of automatically creating the directory listing.") -(defvar url-pgp/pem-entity nil - "*The users PGP/PEM id - usually their email address.") - (defvar url-privacy-level 'none "*How private you want your requests to be. HTTP/1.0 has header fields for various information about the user, including @@ -158,10 +142,6 @@ variable. ") -(defvar url-uudecode-program "uudecode" "*The UUdecode executable.") - -(defvar url-uuencode-program "uuencode" "*The UUencode executable.") - (defvar url-history-list nil "List of urls visited this session.") (defvar url-inhibit-uncompression nil "Do not do decompression if non-nil.") @@ -173,33 +153,19 @@ session.") (defvar url-uncompressor-alist '((".z" . "x-gzip") - (".gz" . "x-gzip") - (".uue" . "x-uuencoded") - (".hqx" . "x-hqx") - (".Z" . "x-compress")) + (".gz" . "x-gzip") + (".uue" . "x-uuencoded") + (".hqx" . "x-hqx") + (".Z" . "x-compress")) "*An assoc list of file extensions and the appropriate content-transfer-encodings for each.") -(defvar url-xterm-command "xterm -title %s -ut -e %s %s %s" - "*Command used to start an xterm window.") - -(defvar url-tn3270-emulator "tn3270" - "The client to run in a subprocess to connect to a tn3270 machine.") - -(defvar url-use-transparent nil - "*Whether to use the transparent package by Brian Tompsett instead of -the builtin telnet functions. Using transparent allows you to have full -vt100 emulation in the telnet and tn3270 links.") - (defvar url-mail-command 'url-mail "*This function will be called whenever url needs to send mail. It should enter a mail-mode-like buffer in the current window. The commands mail-to and mail-subject should still work in this buffer, and it should use mail-header-separator if possible.") -(defvar url-local-exec-path nil - "*A list of possible locations for x-exec scripts.") - (defvar url-proxy-services nil "*An assoc list of access types and servers that gateway them. Looks like ((\"http\" . \"hostname:portnumber\") ....) This is set up @@ -270,23 +236,18 @@ (defvar url-multiple-p t "*If non-nil, multiple queries are possible through ` *URL-*' buffers") (defvar url-default-working-buffer " *URL*" " The default buffer to do all of the processing in.") -(defvar url-working-buffer url-default-working-buffer " The buffer to do all of the processing in. - (It defaults to `url-default-working-buffer' and is bound to ` *URL-*' buffers - when used for multiple requests, cf. `url-multiple-p')") +(defvar url-working-buffer url-default-working-buffer + "The buffer to do all of the processing in. +It defaults to `url-default-working-buffer' and is bound to *URL-* +buffers when used for multiple requests, cf. `url-multiple-p'") (defvar url-current-referer nil "Referer of this page.") (defvar url-current-content-length nil "Current content length.") -(defvar url-current-file nil "Filename of current document.") (defvar url-current-isindex nil "Is the current document a searchable index?") (defvar url-current-mime-encoding nil "MIME encoding of current document.") (defvar url-current-mime-headers nil "An alist of MIME headers.") (defvar url-current-mime-type nil "MIME type of current document.") (defvar url-current-mime-viewer nil "How to view the current MIME doc.") -(defvar url-current-nntp-server nil "What nntp server currently opened.") (defvar url-current-passwd-count 0 "How many times password has failed.") -(defvar url-current-port nil "Port # of the current document.") -(defvar url-current-server nil "Server of the current document.") -(defvar url-current-user nil "Username for ftp login.") -(defvar url-current-type nil "We currently in http or file mode?") (defvar url-gopher-types "0123456789+gIThws:;<" "A string containing character representations of all the gopher types.") (defvar url-mime-separator-chars (mapcar 'identity @@ -320,11 +281,11 @@ (defvar url-request-method nil "The method to use for the next request.") (defvar url-mime-encoding-string nil - "String to send to the server in the Accept-encoding: field in HTTP/1.0 + "*String to send to the server in the Accept-encoding: field in HTTP/1.0 requests. This is created automatically from mm-content-transfer-encodings.") (defvar url-mime-language-string "*" - "String to send to the server in the Accept-language: field in + "*String to send to the server in the Accept-language: field in HTTP/1.0 requests.") (defvar url-mime-accept-string nil @@ -352,24 +313,6 @@ "*Maximum number of times a password will be prompted for when a protected document is denied by the server.") -(defvar url-wais-to-mime - '( - ("WSRC" . "application/x-wais-source") ; A database description - ("TEXT" . "text/plain") ; plain text - ) - "An assoc list of wais doctypes and their corresponding MIME -content-types.") - -(defvar url-waisq-prog "waisq" - "*Name of the waisq executable on this system. This should be the -waisq program from think.com's wais8-b5.1 distribution.") - -(defvar url-wais-gateway-server "www.ncsa.uiuc.edu" - "*The machine name where the WAIS gateway lives.") - -(defvar url-wais-gateway-port "8001" - "*The port # of the WAIS gateway.") - (defvar url-temporary-directory "/tmp" "*Where temporary files go.") (defvar url-show-status t @@ -417,17 +360,12 @@ "^\\([-a-zA-Z0-9+.]+:\\)" "A regular expression that will match an absolute URL.") -(defvar url-configuration-directory nil - "*Where the URL configuration files can be found.") - (defvar url-confirmation-func 'y-or-n-p "*What function to use for asking yes or no functions. Possible values are 'yes-or-no-p or 'y-or-n-p, or any function that takes a single argument (the prompt), and returns t only if a positive answer is gotten.") -(defvar url-find-this-link nil "Link to go to within a document.") - (defvar url-gateway-method 'native "*The type of gateway support to use. Should be a symbol specifying how we are to get a connection off of the @@ -445,7 +383,7 @@ ") (defvar url-running-xemacs (string-match "XEmacs" emacs-version) - "*In XEmacs?.") + "*Got XEmacs?") (defvar url-default-ports '(("http" . "80") ("gopher" . "70") diff -r a0ec055d74dd -r a145efe76779 lisp/w3/url-wais.el --- a/lisp/w3/url-wais.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/w3/url-wais.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,251 +0,0 @@ -;;; url-wais.el --- WAIS Uniform Resource Locator retrieval code -;; Author: wmperry -;; Created: 1997/01/10 00:13:05 -;; Version: 1.4 -;; Keywords: comm, data, processes - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Copyright (c) 1993-1996 by William M. Perry (wmperry@cs.indiana.edu) -;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc. -;;; -;;; This file is not part of GNU Emacs, but the same permissions apply. -;;; -;;; 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. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(require 'url-vars) -(require 'url-parse) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; WAIS support -;;; ------------ -;;; Here are even more gross hacks that I call native WAIS support. -;;; This code requires a working waisq program that is fully -;;; compatible with waisq from think.com -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun url-create-wais-source (server port dbase) - ;; Create a temporary wais source description file. Returns the - ;; file name the description is in. - (let ((x (url-generate-unique-filename)) - (y (get-buffer-create " *waisq-tmp*"))) - (save-excursion - (set-buffer y) - (erase-buffer) - (insert - (format - (concat "(:source\n:version 3\n" - ":ip-name \"%s\"\n:tcp-port %s\n" - ":database-name \"%s\"\n)") - server (if (equal port "") "210" port) dbase)) - (write-region (point-min) (point-max) x nil nil) - (kill-buffer y)) - x)) - -(defun url-wais-stringtoany (str) - ;; Return a wais subelement that specifies STR in any database - (concat "(:any :size " (length str) " :bytes #( " - (mapconcat 'identity str " ") - " ) )")) - -;(defun url-retrieve-wais-docid (server port dbase local-id) -; (call-process "waisretrieve" nil url-working-buffer nil -; (format "%s:%s@%s:%s" (url-unhex-string local-id) -; dbase server port))) - -;(url-retrieve-wais-docid "quake.think.com" "210" "directory-of-servers" -; "0 2608 /proj/wais/wais-sources/vpiej-l.src") -(defun url-retrieve-wais-docid (server port dbase local-id) - ;; Retrieve a wais document. - ;; SERVER is the server the database is on (:ip-name in source description) - ;; PORT is the port number to contact (:tcp-port in the source description) - ;; DBASE is the database name (:database-name in the source description) - ;; LOCAL-ID is the document (:original-local-id in the question description) - (let* ((dbf (url-create-wais-source server port dbase)) - (qstr (format - (concat "(:question :version 2\n" - " :result-documents\n" - " ( (:document-id\n" - " :document\n" - " (:document\n" - " :headline \"\"\n" - " :doc-id\n" - " (:doc-id :original-database %s\n" - " :original-local-id %s )\n" - " :number-of-bytes -1\n" - " :type \"\"\n" - " :source\n" - " (:source-id :filename \"%s\") ) ) ) )") - (url-wais-stringtoany dbase) - (url-wais-stringtoany (url-unhex-string local-id)) - dbf)) - (qf (url-generate-unique-filename))) - (set-buffer (get-buffer-create url-working-buffer)) - (insert qstr) - (write-region (point-min) (point-max) qf nil nil) - (erase-buffer) - (call-process url-waisq-prog nil url-working-buffer nil "-f" qf "-v" "1") - (save-excursion - (set-buffer url-working-buffer) - (setq url-current-file (url-unhex-string local-id))) - (condition-case () - (delete-file dbf) - (error nil)) - (condition-case () - (delete-file qf) - (error nil)))) - -;(url-perform-wais-query "quake.think.com" "210" "directory-of-servers" "SGML") -(defun url-perform-wais-query (server port dbase search) - ;; Perform a wais query. - ;; SERVER is the server the database is on (:ip-name in source description) - ;; PORT is the port number to contact (:tcp-port in the source description) - ;; DBASE is the database name (:database-name in the source description) - ;; SEARCH is the search term (:seed-words in the question description)" - (let ((dbfname (url-create-wais-source server port dbase)) - (qfname (url-generate-unique-filename)) - (results 'url-none-gotten)) - (save-excursion - (url-clear-tmp-buffer) - (insert - (format - (concat "(:question\n" - " :version 2\n" - " :seed-words \"%s\"\n" - " :sourcepath \"" url-temporary-directory "\"\n" - " :sources\n" - " ( (:source-id\n" - " :filename \"%s\"\n" - " )\n" - " )\n" - " :maximum-results 100)\n") - search dbfname)) - (write-region (point-min) (point-max) qfname nil nil) - (erase-buffer) - (call-process url-waisq-prog nil url-working-buffer nil "-g" "-f" qfname) - (set-buffer url-working-buffer) - (erase-buffer) - (setq url-current-server server - url-current-port port - url-current-file dbase) - (insert-file-contents-literally qfname) - (goto-char (point-min)) - (if (re-search-forward "(:question" nil t) - (delete-region (point-min) (match-beginning 0))) - (url-replace-regexp "Process.*finished.*" "") - (subst-char-in-region (point-min) (point-max) 35 32) - (goto-char (point-min)) - (message "Done reading info - parsing results...") - (if (re-search-forward ":result-documents[^(]+" nil t) - (progn - (goto-char (match-end 0)) - (while (eq results 'url-none-gotten) - (condition-case () - (setq results (read (current-buffer))) - (error (progn - (setq results 'url-none-gotten) - (goto-char (match-end 0)))))) - (erase-buffer) - (insert "Results of WAIS search\n" - "

Searched " dbase " for " search "

\n" - "
\n" - "Found " (int-to-string (length results)) - " matches.\n" - "
    \n
  1. " - (mapconcat 'url-parse-wais-doc-id results "\n
  2. ") - "\n
\n
\n")) - (message "No results")) - (setq url-current-mime-type "text/html") - (condition-case () - (delete-file qfname) - (error nil)) - (condition-case () - (delete-file dbfname) - (error nil))))) - -(defun url-wais-anytostring (x) - ;; Convert a (:any ....) wais construct back into a string. - (mapconcat 'char-to-string (car (cdr (memq ':bytes x))) "")) - -(defun url-parse-wais-doc-id (x) - ;; Return a list item that points at the doc-id specified by X - (let* ((document (car (cdr (memq ':document x)))) - (doc-id (car (cdr (memq ':doc-id document)))) - (score (car (cdr (memq ':score x)))) - (title (car (cdr (memq ':headline document)))) - (type (car (cdr (memq ':type document)))) - (size (car (cdr (memq ':number-of-bytes document)))) - (server (car (cdr (memq ':original-server doc-id)))) - (dbase (car (cdr (memq ':original-database doc-id)))) - (localid (car (cdr (memq ':original-local-id doc-id)))) - (dist-server (car (cdr (memq ':distributor-server doc-id)))) - (dist-dbase (car (cdr (memq ':distributor-database doc-id)))) - (dist-id (car (cdr (memq ':distributor-local-id doc-id)))) - (copyright (or (car (cdr (memq ':copyright-disposition doc-id))) 0))) - (format "%s (Score = %s)" - url-current-server url-current-port url-current-file - type size - (url-hexify-string (url-wais-anytostring server)) - (url-hexify-string (url-wais-anytostring dbase)) - (url-hexify-string (url-wais-anytostring localid)) - (url-hexify-string (url-wais-anytostring dist-server)) - (url-hexify-string (url-wais-anytostring dist-dbase)) - (url-hexify-string (url-wais-anytostring dist-id)) - copyright title score))) - -(defun url-grok-wais-href (url) - "Return a list of server, port, database, search-term, doc-id" - (if (string-match "wais:/+\\([^/:]+\\):*\\([^/]*\\)/+\\(.*\\)" url) - (let ((host (url-match url 1)) - (port (url-match url 2)) - (data (url-match url 3))) - (list host port data)) - (make-list 3 nil))) - -(defun url-wais (url) - ;; Retrieve a document via WAIS - (if (and url-wais-gateway-server url-wais-gateway-port) - (url-retrieve - (format "http://%s:%s/%s" - url-wais-gateway-server - url-wais-gateway-port - (substring url (match-end 0) nil))) - (let ((href (url-grok-wais-href url))) - (url-clear-tmp-buffer) - (setq url-current-type "wais" - url-current-server (nth 0 href) - url-current-port (nth 1 href) - url-current-file (nth 2 href)) - (cond - ((string-match "2=\\(.*\\);3=\\([^ ;]+\\)" (nth 2 href)); full link - (url-retrieve-wais-docid (nth 0 href) (nth 1 href) - (url-match (nth 2 href) 1) - (url-match (nth 2 href) 2))) - ((string-match "\\([^\\?]+\\)\\?\\(.*\\)" (nth 2 href)) ; stored query - (url-perform-wais-query (nth 0 href) (nth 1 href) - (url-match (nth 2 href) 1) - (url-match (nth 2 href) 2))) - (t - (insert "WAIS search\n" - "

WAIS search of " (nth 2 href) "

" - "
\n" - (format "
\n" url) - "Enter search term: \n" - "
\n" - "
\n")))))) - -(provide 'url-wais) - diff -r a0ec055d74dd -r a145efe76779 lisp/w3/url.el --- a/lisp/w3/url.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/w3/url.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,13 +1,13 @@ ;;; url.el --- Uniform Resource Locator retrieval tool ;; Author: wmperry -;; Created: 1997/02/07 14:30:25 -;; Version: 1.51 +;; Created: 1997/02/20 15:34:07 +;; Version: 1.57 ;; Keywords: comm, data, processes, hypermedia ;;; LCD Archive Entry: ;;; url|William M. Perry|wmperry@cs.indiana.edu| ;;; Functions for retrieving/manipulating URLs| -;;; 1997/02/07 14:30:25|1.51|Location Undetermined +;;; 1997/02/20 15:34:07|1.57|Location Undetermined ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -97,11 +97,8 @@ (autoload 'url-telnet "url-misc") (autoload 'url-tn3270 "url-misc") (autoload 'url-proxy "url-misc") -(autoload 'url-x-exec "url-misc") (autoload 'url-news "url-news") (autoload 'url-nntp "url-news") -(autoload 'url-decode-pgp/pem "url-pgp") -(autoload 'url-wais "url-wais") (autoload 'url-open-stream "url-gw") (autoload 'url-mime-response-p "url-http") @@ -119,6 +116,13 @@ (autoload 'url-cookie-generate-header-lines "url-cookie") (autoload 'url-cookie-handle-set-cookie "url-cookie") +(autoload 'url-is-cached "url-cache") +(autoload 'url-store-in-cache "url-cache") +(autoload 'url-is-cached "url-cache") +(autoload 'url-create-cached-filename "url-cache") +(autoload 'url-extract-from-cache "url-cache") +(autoload 'url-cache-expired "url-cache") + (require 'md5) (require 'base64) @@ -132,9 +136,6 @@ nil) ; Don't load if no alist ((rassq 'url-file-handler file-name-handler-alist) nil) ; Don't load twice - ((and (string-match "XEmacs\\|Lucid" emacs-version) - (< url-emacs-minor-version 11)) ; Don't load in lemacs 19.10 - nil) (t (setq file-name-handler-alist (let ((new-handler (cons @@ -566,7 +567,8 @@ 1 0 0 (cons 0 0) (cons 0 0) (cons 0 0) -1 (mm-extension-to-mime (url-file-extension - url-current-file)) + (url-filename + url-current-object))) nil 0 0))) (kill-buffer " *url-temp*")))))) ((member type '("ftp" "file")) @@ -809,15 +811,10 @@ ((eq (device-type) 'tty) "(Unix?); TTY") (t "UnkownPlatform"))) - ;; Set up the entity definition for PGP and PEM authentication - (setq url-pgp/pem-entity (or url-pgp/pem-entity - user-mail-address - (format "%s@%s" (user-real-login-name) - (system-name)))) - (setq url-personal-mail-address (or url-personal-mail-address - url-pgp/pem-entity - user-mail-address)) + user-mail-address + (format "%s@%s" (user-real-login-name) + (system-name)))) (if (or (memq url-privacy-level '(paranoid high)) (and (listp url-privacy-level) @@ -907,11 +904,8 @@ (url-register-protocol 'irc nil 'url-identity-expander "6667") (url-register-protocol 'data nil 'url-identity-expander) (url-register-protocol 'rlogin) - (url-register-protocol 'shttp nil nil "80") (url-register-protocol 'telnet) (url-register-protocol 'tn3270) - (url-register-protocol 'wais) - (url-register-protocol 'x-exec) (url-register-protocol 'proxy) (url-register-protocol 'auto 'url-handle-no-scheme) @@ -971,16 +965,11 @@ noproxy "") "\\)")) url-proxy-services)))) - ;; Set the url-use-transparent with decent defaults - (if (not (eq (device-type) 'tty)) - (setq url-use-transparent nil)) - (and url-use-transparent (require 'transparent)) - ;; Set the password entry funtion based on user defaults or guess ;; based on which remote-file-access package they are using. (cond (url-passwd-entry-func nil) ; Already been set - ((boundp 'read-passwd) ; Use secure password if available + ((fboundp 'read-passwd) ; Use secure password if available (setq url-passwd-entry-func 'read-passwd)) ((or (featurep 'efs) ; Using EFS (featurep 'efs-auto)) ; or autoloading efs @@ -992,8 +981,9 @@ (not (string-match "Lucid" (emacs-version))))) (setq url-passwd-entry-func 'ange-ftp-read-passwd)) (t - (url-warn 'security - "Can't determine how to read passwords, winging it."))) + (url-warn + 'security + "(url-setup): Can't determine how to read passwords, winging it."))) ;; Set up the news service if they haven't done so (setq url-news-server @@ -1026,249 +1016,6 @@ (run-hooks 'url-load-hook) (setq url-setup-done t))) -(defun url-cache-file-writable-p (file) - "Follows the documentation of file-writable-p, unlike file-writable-p." - (and (file-writable-p file) - (if (file-exists-p file) - (not (file-directory-p file)) - (file-directory-p (file-name-directory file))))) - -(defun url-prepare-cache-for-file (file) - "Makes it possible to cache data in FILE. -Creates any necessary parent directories, deleting any non-directory files -that would stop this. Returns nil if parent directories can not be -created. If FILE already exists as a non-directory, it changes -permissions of FILE or deletes FILE to make it possible to write a new -version of FILE. Returns nil if this can not be done. Returns nil if -FILE already exists as a directory. Otherwise, returns t, indicating that -FILE can be created or overwritten." - - ;; COMMENT: We don't delete directories because that requires - ;; recursively deleting the directories's contents, which might - ;; eliminate a substantial portion of the cache. - - (cond - ((url-cache-file-writable-p file) - t) - ((file-directory-p file) - nil) - (t - (catch 'upcff-tag - (let ((dir (file-name-directory file)) - dir-parent dir-last-component) - (if (string-equal dir file) - ;; *** Should I have a warning here? - ;; FILE must match a pattern like /foo/bar/, indicating it is a - ;; name only suitable for a directory. So presume we won't be - ;; able to overwrite FILE and return nil. - (throw 'upcff-tag nil)) - - ;; Make sure the containing directory exists, or throw a failure - ;; if we can't create it. - (if (file-directory-p dir) - nil - (or (fboundp 'make-directory) - (throw 'upcff-tag nil)) - (make-directory dir t) - ;; make-directory silently fails if there is an obstacle, so - ;; we must verify its results. - (if (file-directory-p dir) - nil - ;; Look at prefixes of the path to find the obstacle that is - ;; stopping us from making the directory. Unfortunately, there - ;; is no portable function in Emacs to find the parent directory - ;; of a *directory*. So this code may not work on VMS. - (while (progn - (if (eq ?/ (aref dir (1- (length dir)))) - (setq dir (substring dir 0 -1)) - ;; Maybe we're on VMS where the syntax is different. - (throw 'upcff-tag nil)) - (setq dir-parent (file-name-directory dir)) - (not (file-directory-p dir-parent))) - (setq dir dir-parent)) - ;; We have found the longest path prefix that exists as a - ;; directory. Deal with any obstacles in this directory. - (if (file-exists-p dir) - (condition-case nil - (delete-file dir) - (error (throw 'upcff-tag nil)))) - (if (file-exists-p dir) - (throw 'upcff-tag nil)) - ;; Try making the directory again. - (setq dir (file-name-directory file)) - (make-directory dir t) - (or (file-directory-p dir) - (throw 'upcff-tag nil)))) - - ;; The containing directory exists. Let's see if there is - ;; something in the way in this directory. - (if (url-cache-file-writable-p file) - (throw 'upcff-tag t) - (condition-case nil - (delete-file file) - (error (throw 'upcff-tag nil)))) - - ;; The return value, if we get this far. - (url-cache-file-writable-p file)))))) - -(defun url-store-in-cache (&optional buff) - "Store buffer BUFF in the cache" - (if (or (not (get-buffer buff)) - (member url-current-type '("www" "about" "https" "shttp" - "news" "mailto")) - (and (member url-current-type '("file" "ftp" nil)) - (not url-current-server)) - ) - nil - (save-excursion - (and buff (set-buffer buff)) - (let* ((fname (url-create-cached-filename (url-view-url t))) - (fname-hdr (concat (if (memq system-type '(ms-windows ms-dos os2)) - (url-file-extension fname t) - fname) ".hdr")) - (info (mapcar (function (lambda (var) - (cons (symbol-name var) - (symbol-value var)))) - '( url-current-content-length - url-current-file - url-current-isindex - url-current-mime-encoding - url-current-mime-headers - url-current-mime-type - url-current-port - url-current-server - url-current-type - url-current-user - )))) - (cond ((and (url-prepare-cache-for-file fname) - (url-prepare-cache-for-file fname-hdr)) - (write-region (point-min) (point-max) fname nil 5) - (set-buffer (get-buffer-create " *cache-tmp*")) - (erase-buffer) - (insert "(setq ") - (mapcar - (function - (lambda (x) - (insert (car x) " " - (cond ((null (setq x (cdr x))) "nil") - ((stringp x) (prin1-to-string x)) - ((listp x) (concat "'" (prin1-to-string x))) - ((numberp x) (int-to-string x)) - (t "'???")) "\n"))) - info) - (insert ")\n") - (write-region (point-min) (point-max) fname-hdr nil 5))))))) - - -(defun url-is-cached (url) - "Return non-nil if the URL is cached." - (let* ((fname (url-create-cached-filename url)) - (attribs (file-attributes fname))) - (and fname ; got a filename - (file-exists-p fname) ; file exists - (not (eq (nth 0 attribs) t)) ; Its not a directory - (nth 5 attribs)))) ; Can get last mod-time - -(defun url-create-cached-filename-using-md5 (url) - (if url - (expand-file-name (md5 url) - (concat url-temporary-directory "/" - (user-real-login-name))))) - -(defun url-create-cached-filename (url) - "Return a filename in the local cache for URL" - (if url - (let* ((url url) - (urlobj (if (vectorp url) - url - (url-generic-parse-url url))) - (protocol (url-type urlobj)) - (hostname (url-host urlobj)) - (host-components - (cons - (user-real-login-name) - (cons (or protocol "file") - (nreverse - (delq nil - (mm-string-to-tokens - (or hostname "localhost") ?.)))))) - (fname (url-filename urlobj))) - (if (and fname (/= (length fname) 0) (= (aref fname 0) ?/)) - (setq fname (substring fname 1 nil))) - (if fname - (let ((slash nil)) - (setq fname - (mapconcat - (function - (lambda (x) - (cond - ((and (= ?/ x) slash) - (setq slash nil) - "%2F") - ((= ?/ x) - (setq slash t) - "/") - (t - (setq slash nil) - (char-to-string x))))) fname "")))) - - (if (and fname (memq system-type '(ms-windows ms-dos windows-nt)) - (string-match "\\([A-Za-z]\\):[/\\]" fname)) - (setq fname (concat (url-match fname 1) "/" - (substring fname (match-end 0))))) - - (setq fname (and fname - (mapconcat - (function (lambda (x) - (if (= x ?~) "" (char-to-string x)))) - fname "")) - fname (cond - ((null fname) nil) - ((or (string= "" fname) (string= "/" fname)) - url-directory-index-file) - ((= (string-to-char fname) ?/) - (if (string= (substring fname -1 nil) "/") - (concat fname url-directory-index-file) - (substring fname 1 nil))) - (t - (if (string= (substring fname -1 nil) "/") - (concat fname url-directory-index-file) - fname)))) - - ;; Honor hideous 8.3 filename limitations on dos and windows - ;; we don't have to worry about this in Windows NT/95 (or OS/2?) - (if (and fname (memq system-type '(ms-windows ms-dos))) - (let ((base (url-file-extension fname t)) - (ext (url-file-extension fname nil))) - (setq fname (concat (substring base 0 (min 8 (length base))) - (substring ext 0 (min 4 (length ext))))) - (setq host-components - (mapcar - (function - (lambda (x) - (if (> (length x) 8) - (concat - (substring x 0 8) "." - (substring x 8 (min (length x) 11))) - x))) - host-components)))) - - (and fname - (expand-file-name fname - (expand-file-name - (mapconcat 'identity host-components "/") - url-temporary-directory)))))) - -(defun url-extract-from-cache (fnam) - "Extract FNAM from the local disk cache" - (set-buffer (get-buffer-create url-working-buffer)) - (erase-buffer) - (setq url-current-mime-viewer nil) - (insert-file-contents-literally fnam) - (load (concat (if (memq system-type '(ms-windows ms-dos os2)) - (url-file-extension fnam t) - fnam) ".hdr") t t)) - ;;;###autoload (defun url-get-url-at-point (&optional pt) "Get the URL closest to point, but don't change your @@ -1536,8 +1283,7 @@ "Do any necessary uncompression on `url-working-buffer'" (set-buffer url-working-buffer) (if (not url-inhibit-uncompression) - (let* ((extn (url-file-extension url-current-file)) - (decoder nil) + (let* ((decoder nil) (code-1 (cdr-safe (assoc "content-transfer-encoding" url-current-mime-headers))) @@ -1582,6 +1328,7 @@ (defun url-default-callback (buf) (url-download-minor-mode nil) + (url-store-in-cache) (cond ((save-excursion (set-buffer buf) (and url-current-callback-func @@ -1624,10 +1371,11 @@ (if (not url-current-mime-type) (setq url-current-mime-type (mm-extension-to-mime (url-file-extension - url-current-file))))))) - (if (member status '(401 301 302 303 204)) - nil - (funcall url-default-retrieval-proc (buffer-name url-working-buffer)))))) + (url-filename + url-current-object))))) + (if (member status '(401 301 302 303 204)) + nil + (funcall url-default-retrieval-proc (buffer-name url-working-buffer))))))))) (defun url-remove-relative-links (name) ;; Strip . and .. from pathnames @@ -1682,54 +1430,11 @@ "View the current document's URL. Optional argument NO-SHOW means just return the URL, don't show it in the minibuffer." (interactive) - (let ((url "")) - (cond - ((equal url-current-type "gopher") - (setq url (format "%s://%s%s/%s" - url-current-type url-current-server - (if (or (null url-current-port) - (string= "70" url-current-port)) "" - (concat ":" url-current-port)) - url-current-file))) - ((equal url-current-type "news") - (setq url (concat "news:" - (if (not (equal url-current-server - url-news-server)) - (concat "//" url-current-server - (if (or (null url-current-port) - (string= "119" url-current-port)) - "" - (concat ":" url-current-port)) "/")) - url-current-file))) - ((equal url-current-type "about") - (setq url (concat "about:" url-current-file))) - ((member url-current-type '("http" "shttp" "https")) - (setq url (format "%s://%s%s/%s" url-current-type url-current-server - (if (or (null url-current-port) - (string= "80" url-current-port)) - "" - (concat ":" url-current-port)) - (if (and url-current-file - (= ?/ (string-to-char url-current-file))) - (substring url-current-file 1 nil) - url-current-file)))) - ((equal url-current-type "ftp") - (setq url (format "%s://%s%s/%s" url-current-type - (if (and url-current-user - (not (string= "anonymous" url-current-user))) - (concat url-current-user "@") "") - url-current-server - (if (and url-current-file - (= ?/ (string-to-char url-current-file))) - (substring url-current-file 1 nil) - url-current-file)))) - ((and (member url-current-type '("file" nil)) url-current-file) - (setq url (format "file:%s" url-current-file))) - ((equal url-current-type "www") - (setq url (format "www:/%s/%s" url-current-server url-current-file))) - (t - (setq url nil))) - (if (not no-show) (message "%s" url) url))) + (if (not url-current-object) + nil + (if no-show + (url-recreate-url url-current-object) + (message "%s" (url-recreate-url url-current-object))))) (defun url-parse-Netscape-history (fname) ;; Parse a Netscape/X style global history list. @@ -2114,14 +1819,7 @@ (url-lazy-message "Retrieving %s..." url) (apply 'call-process url-external-retrieval-program nil t nil args) - (url-lazy-message "Retrieving %s... done" url) - (if (and type urlobj) - (setq url-current-server (url-host urlobj) - url-current-type (url-type urlobj) - url-current-port (url-port urlobj) - url-current-file (url-filename urlobj))) - (if (member url-current-file '("/" "")) - (setq url-current-mime-type "text/html")))))) + (url-lazy-message "Retrieving %s... done" url))))) (defun url-get-normalized-date (&optional specified-time) ;; Return a 'real' date string that most HTTP servers can understand. @@ -2152,28 +1850,6 @@ (concat "[" (nth 1 (current-time-zone)) "]"))))) -;;;###autoload -(defun url-cache-expired (url mod) - "Return t iff a cached file has expired." - (if (not (string-match url-nonrelative-link url)) - t - (let* ((urlobj (url-generic-parse-url url)) - (type (url-type urlobj))) - (cond - (url-standalone-mode - (not (file-exists-p (url-create-cached-filename urlobj)))) - ((string= type "http") - (if (not url-standalone-mode) t - (not (file-exists-p (url-create-cached-filename urlobj))))) - ((not (fboundp 'current-time)) - t) - ((member type '("file" "ftp")) - (if (or (equal mod '(0 0)) (not mod)) - (return t) - (or (> (nth 0 mod) (nth 0 (current-time))) - (> (nth 1 mod) (nth 1 (current-time)))))) - (t nil))))) - (defun url-get-working-buffer-name () "Get a working buffer name such as ` *URL-*' without a live process and empty" (let ((num 1) @@ -2224,95 +1900,79 @@ nil)))) (defun url-retrieve-internally (url &optional no-cache) - (let ((url-working-buffer (if (and url-multiple-p - (string-equal - (if (bufferp url-working-buffer) - (buffer-name url-working-buffer) - url-working-buffer) - url-default-working-buffer)) - (url-get-working-buffer-name) - url-working-buffer))) - (if (get-buffer url-working-buffer) - (save-excursion - (set-buffer url-working-buffer) - (erase-buffer) - (setq url-current-can-be-cached (not no-cache)) - (set-buffer-modified-p nil))) - (let* ((urlobj (url-generic-parse-url url)) - (type (url-type urlobj)) - (url-using-proxy (if (url-host urlobj) - (url-find-proxy-for-url urlobj - (url-host urlobj)) - nil)) - (handler nil) - (original-url url) - (cached nil) - (tmp url-current-file)) - (if url-using-proxy (setq type "proxy")) - (setq cached (url-is-cached url) - cached (and cached (not (url-cache-expired url cached))) - handler (if cached 'url-extract-from-cache - (car-safe - (cdr-safe (assoc (or type "auto") - url-registered-protocols)))) - url (if cached (url-create-cached-filename url) url)) - (save-excursion - (set-buffer (get-buffer-create url-working-buffer)) - (setq url-current-can-be-cached (not no-cache))) - ; (if url-be-asynchronous - ; (url-download-minor-mode t)) - (if (and handler (fboundp handler)) - (funcall handler url) - (set-buffer (get-buffer-create url-working-buffer)) - (setq url-current-file tmp) - (erase-buffer) - (insert " Link Error! \n" - "

An error has occurred...

\n" - (format "The link type `%s'" type) - " is unrecognized or unsupported at this time.

\n" - "If you feel this is an error, please " - "send me mail." - "

William Perry

" - "
" url-bug-address "
") - (setq url-current-file "error.html")) - (if (and - (not url-be-asynchronous) - (get-buffer url-working-buffer)) - (progn - (set-buffer url-working-buffer) - - (url-clean-text))) - (cond - ((equal type "wais") nil) - ((and url-be-asynchronous (not cached) (member type '("http" "proxy"))) - nil) - (url-be-asynchronous - (funcall url-default-retrieval-proc (buffer-name))) - ((not (get-buffer url-working-buffer)) nil) - ((and (not url-inhibit-mime-parsing) - (or cached (url-mime-response-p t))) - (or cached (url-parse-mime-headers nil t)))) - (if (and (or (not url-be-asynchronous) - (not (equal type "http"))) - (not url-current-mime-type)) - (if (url-buffer-is-hypertext) - (setq url-current-mime-type "text/html") - (setq url-current-mime-type (mm-extension-to-mime - (url-file-extension - url-current-file))))) - (if (and url-automatic-caching url-current-can-be-cached - (not url-be-asynchronous)) - (save-excursion - (url-store-in-cache url-working-buffer))) - (if (not url-global-history-hash-table) - (setq url-global-history-hash-table (make-hash-table :size 131 - :test 'equal))) - (if (not (string-match "^about:" original-url)) - (progn - (setq url-history-changed-since-last-save t) - (cl-puthash original-url (current-time) - url-global-history-hash-table))) - (cons cached url-working-buffer)))) + (let* ((url-working-buffer (if (and url-multiple-p + (string-equal + (if (bufferp url-working-buffer) + (buffer-name url-working-buffer) + url-working-buffer) + url-default-working-buffer)) + (url-get-working-buffer-name) + url-working-buffer)) + (urlobj (url-generic-parse-url url)) + (type (url-type urlobj)) + (url-using-proxy (if (url-host urlobj) + (url-find-proxy-for-url urlobj + (url-host urlobj)) + nil)) + (handler nil) + (original-url url) + (cached nil)) + (if url-using-proxy (setq type "proxy")) + (setq cached (url-is-cached url) + cached (and cached (not (url-cache-expired url cached))) + handler (if cached + 'url-extract-from-cache + (car-safe + (cdr-safe (assoc (or type "auto") + url-registered-protocols)))) + url (if cached (url-create-cached-filename url) url)) + (save-excursion + (set-buffer (get-buffer-create url-working-buffer)) + (setq url-current-can-be-cached (not no-cache) + url-current-object urlobj)) + (if (and handler (fboundp handler)) + (funcall handler url) + (set-buffer (get-buffer-create url-working-buffer)) + (erase-buffer) + (setq url-current-mime-type "text/html") + (insert " Link Error! \n" + "

An error has occurred...

\n" + (format "The link type `%s'" type) + " is unrecognized or unsupported at this time.

\n" + "If you feel this is an error in Emacs-W3, please " + "send me mail." + "

William Perry

" + "
" url-bug-address "
")) + (cond + ((and url-be-asynchronous (not cached) (member type '("http" "proxy"))) + nil) + (url-be-asynchronous + (funcall url-default-retrieval-proc (buffer-name))) + ((not (get-buffer url-working-buffer)) nil) + ((and (not url-inhibit-mime-parsing) + (or cached (url-mime-response-p t))) + (or cached (url-parse-mime-headers nil t)))) + (if (and (or (not url-be-asynchronous) + (not (equal type "http"))) + url-current-object + (not url-current-mime-type)) + (if (url-buffer-is-hypertext) + (setq url-current-mime-type "text/html") + (setq url-current-mime-type (mm-extension-to-mime + (url-file-extension + (url-filename + url-current-object)))))) + (if (not url-be-asynchronous) + (url-store-in-cache url-working-buffer)) + (if (not url-global-history-hash-table) + (setq url-global-history-hash-table (make-hash-table :size 131 + :test 'equal))) + (if (not (string-match "^\\(about\\|www\\):" original-url)) + (progn + (setq url-history-changed-since-last-save t) + (cl-puthash original-url (current-time) + url-global-history-hash-table))) + (cons cached url-working-buffer))) ;;;###autoload (defun url-retrieve (url &optional no-cache expected-md5) @@ -2331,12 +1991,6 @@ (if (and url (string-match "^url:" url)) (setq url (substring url (match-end 0) nil))) (let ((status (url-retrieve-internally url no-cache))) - (if (and expected-md5 url-check-md5s) - (let ((cur-md5 (md5 (current-buffer)))) - (if (not (string= cur-md5 expected-md5)) - (and (not (funcall url-confirmation-func - "MD5s do not match, use anyway? ")) - (error "MD5 error."))))) status)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff -r a0ec055d74dd -r a145efe76779 lisp/w3/w3-about.el --- a/lisp/w3/w3-about.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/w3/w3-about.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,7 +1,7 @@ ;;; w3-about.el --- About pages for emacs-w3 ;; Author: wmperry -;; Created: 1997/01/10 00:13:05 -;; Version: 1.7 +;; Created: 1997/02/18 23:36:35 +;; Version: 1.8 ;; Keywords: hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -35,9 +35,7 @@ (save-excursion (set-buffer (get-buffer-create url-working-buffer)) (erase-buffer) - (setq url-current-type "about" - url-current-file node - url-current-mime-viewer (mm-mime-info "text/html" nil 5) + (setq url-current-mime-viewer (mm-mime-info "text/html" nil 5) url-current-mime-headers '(("content-type" . "text/html"))) (cond ((string= "" node) diff -r a0ec055d74dd -r a145efe76779 lisp/w3/w3-display.el --- a/lisp/w3/w3-display.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/w3/w3-display.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,7 +1,7 @@ ;;; w3-display.el --- display engine v99999 ;; Author: wmperry -;; Created: 1997/02/15 23:38:28 -;; Version: 1.128 +;; Created: 1997/02/20 21:48:44 +;; Version: 1.135 ;; Keywords: faces, help, hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -367,6 +367,7 @@ (goto-char (point-max)) (add-text-properties w3-scratch-start-point (point) (list 'face w3-active-faces + 'html-stack w3-display-open-element-stack 'start-open t 'end-open t 'rear-nonsticky t @@ -414,7 +415,8 @@ (pop check))))) (defun w3-follow-hyperlink (widget &rest ignore) - (let* ((target (widget-get widget 'target)) + (let* ((target (or (widget-get widget 'target) + w3-base-target)) (href (widget-get widget 'href))) (if target (setq target (intern (downcase target)))) (case target @@ -424,6 +426,11 @@ (delete-other-windows) (w3-fetch href)) (otherwise + (and target + (let ((window-distance (cdr-safe (assq target w3-target-window-distances)))) + (if (numberp window-distance) + (other-window window-distance) + (error "target %S not found." target)))) (w3-fetch href))))) (defun w3-balloon-help-callback (object &optional event) @@ -1497,6 +1504,7 @@ (right-margin-stack (list fill-column)) (left-margin-stack (list 0)) (inhibit-read-only t) + (widget-push-button-gui nil) node insert-before insert-after @@ -1648,26 +1656,37 @@ (w3-handle-empty-tag)) (frameset (if w3-display-frames - (w3-handle-content node) + (progn + (push 'frameset w3-frameset-structure) + (let ((cols (assq 'cols args)) + (rows (assq 'rows args))) + (if rows + (setq w3-frameset-dimensions (push rows w3-frameset-dimensions))) + (if cols + (setq w3-frameset-dimensions (push cols w3-frameset-dimensions)))) + (w3-handle-content node)) (w3-handle-empty-tag))) (frame - (let* ((href (or (w3-get-attribute 'src) - (w3-get-attribute 'href))) - (name (or (w3-get-attribute 'name) - (w3-get-attribute 'title) - (w3-get-attribute 'alt) - "Unknown frame name"))) - (w3-handle-content - (list tag args - (list - (list 'p nil - (list - (list 'a - (cons (cons 'href href) - args) - (list - "Fetch frame: " - name))))))))) + (if w3-display-frames + (let* ((href (or (w3-get-attribute 'src) + (w3-get-attribute 'href))) + (name (or (w3-get-attribute 'name) + (w3-get-attribute 'title) + (w3-get-attribute 'alt) + "Unknown frame name"))) + (push 'frame w3-frameset-structure) + (w3-handle-content + (list tag args + (list + (list 'p nil + (list + (list 'a + (cons (cons 'href href) + args) + (list + (car w3-frame-labels) + name + (cdr w3-frame-labels))))))))))) (noframes (if w3-display-frames (w3-handle-empty-tag) @@ -1775,11 +1794,12 @@ (set-buffer (generate-new-buffer "Untitled"))) (setq w3-current-form-number 0 w3-display-open-element-stack nil - w3-last-fill-pos (point-min) - fill-column (min (- (or w3-strict-width (window-width)) - w3-right-margin) - (or w3-maximum-line-length - (window-width)))) + w3-last-fill-pos (point-min)) + (setcar right-margin-stack + (min (- (or w3-strict-width (window-width)) + w3-right-margin) + (or w3-maximum-line-length + (window-width)))) (switch-to-buffer (current-buffer)) (buffer-disable-undo (current-buffer)) (mapcar (function (lambda (x) (set (car x) (cdr x)))) info) @@ -1790,10 +1810,6 @@ (setq w3-current-stylesheet (css-copy-stylesheet w3-user-stylesheet) w3-last-fill-pos (point) - fill-column (min (- (or w3-strict-width (window-width)) - w3-right-margin) - (or w3-maximum-line-length - (window-width))) fill-prefix "") (set (make-local-variable 'inhibit-read-only) t)) (w3-handle-content node) @@ -1840,6 +1856,9 @@ (rename-buffer (generate-new-buffer-name (w3-fix-spaces potential-title))))) (w3-handle-empty-tag)) + (base + (setq w3-base-target (cdr-safe (assq 'target args))) + (w3-handle-content node)) (form (setq w3-current-form-number (1+ w3-current-form-number)) (let* ( @@ -2016,9 +2035,15 @@ (condition-case nil (widget-value-set widget glyph) (error nil)))) + (if (and url-current-object (url-target url-current-object)) + (progn + (push-mark (point) t) + (w3-find-specific-link (url-target url-current-object))) + (goto-char (point-min))) (and (not w3-running-xemacs) (not (eq (device-type) 'tty)) (w3-fixup-eol-faces)) + (message "Drawing... done") ;;(w3-handle-headers) ) @@ -2067,7 +2092,6 @@ (w3-finish-drawing) (w3-mode) (set-buffer-modified-p nil) - (goto-char (point-min)) (if url-keep-history (let ((url (url-view-url t))) (if (not url-history-list) @@ -2077,4 +2101,132 @@ (w3-shuffle-history-menu))))) ) +(defun w3-frames (&optional new-frame) + "Set up and fetch W3 frames. With optional prefix, do so in a new frame." + (interactive "P") + (let* ((old-asynch url-be-asynchronous) + (structure (reverse w3-frameset-structure)) + (dims (or (reverse w3-frameset-dimensions) + t))) + (if new-frame + (select-frame (make-frame-command))) + (goto-char (point-min)) + (setq-default url-be-asynchronous nil) + ;; set up frames + (while (and structure dims) + (let* ((current-dims (list (car dims))) + (cols (cdr-safe (assq 'cols current-dims))) + (rows (cdr-safe (assq 'rows current-dims)))) + (if (eq (car structure) 'frameset) + (pop structure)) + ;; columns ? + (if cols + (setq cols (w3-decode-frameset-dimensions cols (window-width))) + ;; rows ? + (if rows + (setq rows (w3-decode-frameset-dimensions rows (window-height))) + ;; default: columns of equal width + (let ((nb-windows 0)) + (save-excursion + (while (re-search-forward w3-frame-regexp nil t) + (setq nb-windows (1+ nb-windows)))) + (let ((fwidth (/ (window-width) nb-windows))) + (while (> nb-windows 0) + (push fwidth cols) + (setq nb-windows (1- nb-windows))))))) + (while (eq (car structure) 'frame) + (if (re-search-forward w3-frame-regexp nil t) + (progn + (if (cdr cols) + (split-window-horizontally (min (car cols) + (- (window-width) 12))) + (if (cdr rows) + (split-window-vertically (min (car rows) + (- (window-height) 12))))) + (pop cols) + (pop rows) + (goto-char (+ (match-beginning 0) 5)) + (let ((name (buffer-substring-no-properties (match-beginning 1) (match-end 1))) + (w3-notify 'semibully)) + (w3-widget-button-press) + (setq w3-frame-name name + w3-target-window-distances nil)) + (other-window 1))) + (pop structure))) + (if (consp dims) + (pop dims) + (setq dims nil))) + ;; compute target window distances + (let ((origin-buffer (current-buffer)) + (stop nil)) + (while (not stop) + (or w3-target-window-distances + (setq w3-target-window-distances + (w3-compute-target-window-distances))) + (other-window 1) + (if (eq (current-buffer) origin-buffer) + (setq stop t)))) + (setq-default url-be-asynchronous old-asynch))) + +(defun w3-compute-target-window-distances () + "Compute an alist of target names and window distances" + (let ((origin-buffer (current-buffer)) + (distance 0) + (stop nil) + (window-distances nil)) + (while (not stop) + (if w3-frame-name + (push (cons (intern (downcase w3-frame-name)) distance) + window-distances)) + (other-window 1) + (setq distance (1+ distance)) + (if (eq (current-buffer) origin-buffer) + (setq stop t))) + window-distances)) + +(defun w3-decode-frameset-dimensions (dims available-dimension) + "Returns numbers of lines or columns in Emacs, computed from specified frameset dimensions" + (let ((dimensions nil)) + (if dims + (let ((nb-stars 0) + (remaining-available-dimension available-dimension)) + (while (string-match "\\(\\*\\|[0-9]+%?\\)" dims) + (let ((match (substring dims (match-beginning 1) (match-end 1)))) + (setq dims (substring dims (match-end 1))) + (cond ((string-match "\\*" match) + ;; * : divide rest equally + (push '* dimensions) + (setq nb-stars (1+ nb-stars))) + (t + (cond ((string-match "\\([0-9]+\\)%" match) + ;; percentage of available height + (push (/ (* (car (read-from-string (substring match 0 -1))) + available-dimension) + 100) + dimensions)) + (t + ;; absolute number: pixel height + (push (max (1+ (/ (car (read-from-string match)) + (frame-char-height))) + window-min-height) + dimensions))) + (setq remaining-available-dimension + (- remaining-available-dimension (car dimensions))))))) + (if (zerop nb-stars) + ;; push => reverse order + (reverse dimensions) + ;; substitute numbers for * + (let ((star-replacement (/ remaining-available-dimension nb-stars)) + (star-dimensions dimensions)) + (setq dimensions nil) + (while star-dimensions + (push (if (eq '* (car star-dimensions)) + star-replacement + (car star-dimensions)) + dimensions) + (pop star-dimensions)) + ;; push + push => in order + dimensions)))))) + + (provide 'w3-display) diff -r a0ec055d74dd -r a145efe76779 lisp/w3/w3-e19.el --- a/lisp/w3/w3-e19.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/w3/w3-e19.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,7 +1,7 @@ ;;; w3-e19.el --- Emacs 19.xx specific functions for emacs-w3 ;; Author: wmperry -;; Created: 1997/01/19 20:04:48 -;; Version: 1.16 +;; Created: 1997/02/18 23:32:51 +;; Version: 1.18 ;; Keywords: faces, help, mouse, hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -31,6 +31,8 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (require 'w3-forms) (require 'font) +(require 'w3-script) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Help menu ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -98,35 +100,21 @@ (defun w3-mode-version-specifics () ;; Emacs 19 specific stuff for w3-mode (make-local-variable 'track-mouse) - (if w3-track-mouse (setq track-mouse t)) - '(if (or (memq (device-type) '(x pm ns))) - (w3-build-FSF19-menu))) + (if w3-track-mouse (setq track-mouse t))) (defun w3-mouse-handler (e) "Function to message the url under the mouse cursor" (interactive "e") (let* ((pt (posn-point (event-start e))) (good (eq (posn-window (event-start e)) (selected-window))) - (widget (and good pt (number-or-marker-p pt) (widget-at pt))) - (link (and widget (or (widget-get widget 'href) - (widget-get widget 'name)))) - (form (and widget (widget-get widget :w3-form-data))) - (imag nil) ; (nth 1 (memq 'w3graphic props)))) - ) - (cond - (link (message "%s" (w3-widget-echo widget))) - (form - (cond - ((eq 'submit (w3-form-element-type form)) - (message "Submit form to %s" - (cdr-safe (assq 'action (w3-form-element-action form))))) - ((eq 'reset (w3-form-element-type form)) - (message "Reset form contents")) - (t - (message "Form entry (name=%s, type=%s)" (w3-form-element-name form) - (w3-form-element-type form))))) - (imag (message "Inlined image (%s)" (car imag))) - (t (message ""))))) + (mouse-events nil)) + (if (not (and good pt (number-or-marker-p pt))) + nil + (widget-echo-help pt) + ;; Need to handle onmouseover, on mouseout + (setq mouse-events (w3-script-find-event-handlers pt 'mouse)) + (if (assq 'onmouseover mouse-events) + (w3-script-evaluate-form (cdr (assq 'onmouseover mouse-events))))))) (defun w3-color-values (color) (cond diff -r a0ec055d74dd -r a145efe76779 lisp/w3/w3-elisp.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/w3/w3-elisp.el Mon Aug 13 09:15:49 2007 +0200 @@ -0,0 +1,132 @@ +;;; w3-elisp.el --- Scripting support for emacs-lisp +;; Author: wmperry +;; Created: 1997/02/19 23:44:26 +;; Version: 1.5 +;; Keywords: hypermedia, scripting + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; 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. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(require 'cl) + +(mapcar + (function + (lambda (x) + (put x 'w3-safe t))) + '(;; Any safe functions for untrusted scripts should go here. + ;; Basic stuff + message + format garbage-collect progn prog1 prog2 progn-with-message + while current-time current-time-string + plist-member plist-to-alist plist-get + assoc memq member function lambda point + + ;; Device querying + device-pixel-height device-type device-color-cells + device-mm-height device-class device-bitplanes + device-on-window-system-p device-pixel-width + device-mm-width device-baud-rate + + ;; Frame querying + frame-type frame-name frame-device frame-parameters + frame-height frame-pixel-width frame-pixel-height + frame-width frame-property + + ;; Window querying + window-frame window-height window-width + window-pixel-width window-pixel-height + + ;; Buffer querying + buffer-name buffer-substring buffer-substring-no-properties + buffer-size buffer-string + + ;; Text properties, read-only + get-text-property text-properties-at text-property-bounds + text-property-not-all + + ;; URL loading stuff + url-insert-file-contents url-view-url + + ;; Interfacing to W3 + w3-fetch w3-refresh-buffer w3-view-this-url + + ;; Face stuff - is this really safe? + make-face set-face-foreground set-face-underline-p + set-face-doc-string set-face-parent set-face-dim-p set-face-background + set-face-background-pixmap set-face-property set-face-blinking-p + set-face-font-family set-face-reverse-p set-face-strikethru-p + set-face-font-size set-face-font set-face-display-table + set-face-highlight-p + + ;; All the XEmacs event manipulation functions + event-live-p event-glyph-extent event-glyph-y-pixel event-x-pixel + event-type event-glyph event-button event-over-text-area-p + event-glyph-x-pixel event-buffer event-device event-properties + event-process event-timestamp event-modifier-bits event-console + event-window-y-pixel event-window event-window-x-pixel event-point + event-function event-over-toolbar-p event-matches-key-specifier-p + event-over-glyph-p event-frame event-x event-channel event-y + event-screen event-to-character event-over-border-p + event-toolbar-button event-closest-point event-object event-key + event-modifiers event-y-pixel event-over-modeline-p + event-modeline-position + ) + ) + +(defsubst w3-elisp-safe-function (func args) + (let ((validator (get func 'w3-safe))) + (cond + ((eq t validator) t) ; Explicit allow + ((eq nil validator) nil) ; Explicit deny + ((fboundp validator) ; Function to call + (funcall validator func args)) + ((boundp validator) ; Variable to check + (symbol-value validator)) + (t nil)))) ; Fallback to unsafe + +(defun w3-elisp-safe-expression (exp) + "Return t if-and-only-if EXP is safe to evaluate." + (cond + ((and (listp exp) (not (listp (cdr exp)))) ; A cons cell + t) + ((or ; self-quoters + (vectorp exp) + (numberp exp) + (symbolp exp) + (stringp exp) + (keymapp exp)) + t) + ((listp exp) ; Function call - check arguments + (if (w3-elisp-safe-function (car exp) (cdr exp)) + (let ((args (cdr exp)) + (rval t)) + (while args + (if (not (w3-elisp-safe-expression (pop args))) + (setq args nil + rval nil))) + rval))) + ;; How to handle the insane # of native types? + (t nil))) + +(defun w3-elisp-safe-eval (form) + (and (w3-elisp-safe-expression form) (eval form))) + +(provide 'w3-elisp) diff -r a0ec055d74dd -r a145efe76779 lisp/w3/w3-forms.el --- a/lisp/w3/w3-forms.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/w3/w3-forms.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,7 +1,7 @@ ;;; w3-forms.el --- Emacs-w3 forms parsing code for new display engine ;; Author: wmperry -;; Created: 1997/02/13 23:10:23 -;; Version: 1.70 +;; Created: 1997/02/20 21:40:42 +;; Version: 1.73 ;; Keywords: faces, help, comm, data, languages ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -501,6 +501,7 @@ (put 'option 'w3-summarize-function 'w3-form-summarize-option-list) (put 'keygen 'w3-summarize-function 'w3-form-summarize-keygen-list) (put 'image 'w3-summarize-function 'w3-form-summarize-image) +(put 'password 'w3-summarize-function 'w3-form-summarize-password) (put 'hidden 'w3-summarize-function 'ignore) (defun w3-form-summarize-field (widget &rest ignore) @@ -525,7 +526,7 @@ ;; more closely follow the widget-y way of just returning the string ;; instead of having the underlying :help-echo or :emacspeak-help ;; implementation do it. - (message "%s" msg))) + (and msg (message "%s" msg)))) (defsubst w3-form-field-label (data) ;;; FIXXX!!! Need to reimplement using the new forms implementation! @@ -539,6 +540,12 @@ (format "Text field %s set to: %s" (or label (concat "called " name)) value))) +(defun w3-form-summarize-password (data widget) + (let ((label (w3-form-field-label data)) + (name (w3-form-element-name data))) + (format "Password field %s is a secret. Shhh." + (or label (concat "called " name))))) + (defun w3-form-summarize-multiline (data widget) (let ((name (w3-form-element-name data)) (label (w3-form-field-label data)) @@ -580,8 +587,11 @@ (label (w3-form-field-label data)) (cur-value (widget-value (w3-form-element-widget data))) (this-value (widget-value (widget-get-sibling widget)))) - (format "Radio button %s is %s, could be %s" (or label name) cur-value - this-value))) + (if (equal this-value cur-value) + (format "Radio group %s has %s pressed" + (or label name) this-value) + (format "Press this to change radio group %s from %s to %s" (or label name) cur-value + this-value)))) (defun w3-form-summarize-file-browser (data widget) (let ((name (w3-form-element-name data)) @@ -857,9 +867,6 @@ (w3-form-encode-helper result) "\n")) query)) -(defun w3-form-encode-application/x-w3-wais (result) - (cdr (car (w3-form-encode-helper result)))) - (defun w3-form-encode-application/x-gopher-query (result) (concat "\t" (cdr (car (w3-form-encode-helper result))))) diff -r a0ec055d74dd -r a145efe76779 lisp/w3/w3-hot.el --- a/lisp/w3/w3-hot.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/w3/w3-hot.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,7 +1,7 @@ ;;; w3-hot.el --- Main functions for emacs-w3 on all platforms/versions ;; Author: wmperry -;; Created: 1997/01/10 00:13:05 -;; Version: 1.11 +;; Created: 1997/02/18 23:36:48 +;; Version: 1.12 ;; Keywords: faces, help, comm, news, mail, processes, mouse, hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -160,7 +160,7 @@ (progn (w3-show-hotlist) (rename-buffer (concat "Hotlist \"" regexp "\"")) - (setq url-current-file (concat "hotlist/" regexp))) + (url-set-filename url-current-object (concat "hotlist/" regexp))) (and save-buf (save-excursion (set-buffer save-buf) (rename-buffer "Hotlist"))))))) diff -r a0ec055d74dd -r a145efe76779 lisp/w3/w3-jscript.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/w3/w3-jscript.el Mon Aug 13 09:15:49 2007 +0200 @@ -0,0 +1,30 @@ +;;; w3-elisp.el --- Scripting support for javascript +;; Author: wmperry +;; Created: 1997/02/17 16:00:11 +;; Version: 1.2 +;; Keywords: hypermedia, scripting + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; 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. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; FIXME! Well, actually IMPLEMENTME! + +(provide 'w3-jscript) diff -r a0ec055d74dd -r a145efe76779 lisp/w3/w3-script.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/w3/w3-script.el Mon Aug 13 09:15:49 2007 +0200 @@ -0,0 +1,92 @@ +;;; w3-script.el --- Scripting support +;; Author: wmperry +;; Created: 1997/02/18 23:32:46 +;; Version: 1.4 +;; Keywords: hypermedia, scripting + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; 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. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(require 'cl) +(require 'w3-elisp) +(require 'w3-jscript) + +;; Event Handlers +;; onclick ; It was clicked on +;; onchange ; Text area was changed +;; onselect ; Menu choice changed +;; onmouseover ; Mouse is over us +;; onmouseout ; Mouse left us +;; onblur ; We lost focus +;; onfocus ; We gained focus +;; onload ; We got loaded +;; onunload ; We got unloaded +;; onreset ; Form got reset +;; onsubmit ; From is about to be submitted +;; onabort ; User cancelled loading an image +;; onerror ; Error occurred loading an image + +(defvar w3-do-scripting t + "*Whether to handle client-side scripting or not. +If you are ultra-paranoid, set this to `nil'") + +(defvar w3-current-scripting-language 'elisp) +(make-variable-buffer-local 'w3-current-scripting-language) + +(put 'form 'w3-event-handlers + '(onclick onchange onselect onblur onfocus onreset onsubmit)) + +(put 'mouse 'w3-event-handlers '(onmouseover onmouseout)) + +(put 'misc 'w3-event-handlers '(onload onunload)) + +(put 'all 'w3-event-handlers (append (get 'form 'w3-event-handlers) + (get 'mouse 'w3-event-handlers))) + +(defun w3-script-find-event-handlers (pt type) + (if w3-do-scripting + (let* ((html-stack (get-text-property pt 'html-stack)) + (args nil) + (rval nil) + (cur nil)) + (while html-stack + (setq args (cdr (pop html-stack))) + (while (setq cur (pop args)) + (if (memq (car cur) (get type 'w3-event-handlers)) + (setq rval (cons cur rval))))) + (nreverse rval)))) + +(defun w3-script-evaluate-form (f) + (if w3-do-scripting + (case w3-current-scripting-language + (elisp + (let ((st 0) + (form nil) + (max (length f))) + (while (and (< st max) (setq form (read-from-string f st))) + (setq st (cdr form) + form (car form)) + (w3-elisp-safe-eval form)))) + (otherwise + (error "Unimplemented scripting language: %S" + w3-current-scripting-language))))) + +(provide 'w3-script) diff -r a0ec055d74dd -r a145efe76779 lisp/w3/w3-vars.el --- a/lisp/w3/w3-vars.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/w3/w3-vars.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,7 +1,7 @@ ;;; w3-vars.el,v --- All variable definitions for emacs-w3 ;; Author: wmperry -;; Created: 1997/02/15 23:38:52 -;; Version: 1.91 +;; Created: 1997/02/22 15:18:42 +;; Version: 1.97 ;; Keywords: comm, help, hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -30,7 +30,7 @@ ;;; Variable definitions for w3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defconst w3-version-number - (let ((x "p3.0.60")) + (let ((x "p3.0.62")) (if (string-match "State:[ \t\n]+.\\([^ \t\n]+\\)" x) (setq x (substring x (match-beginning 1) (match-end 1))) (setq x (substring x 1))) @@ -38,7 +38,7 @@ (function (lambda (x) (if (= x ?-) "." (char-to-string x)))) x "")) "Version # of w3-mode.") -(defconst w3-version-date (let ((x "1997/02/15 23:38:52")) +(defconst w3-version-date (let ((x "1997/02/22 15:18:42")) (if (string-match "Date: \\([^ \t\n]+\\)" x) (substring x (match-beginning 1) (match-end 1)) x)) @@ -83,6 +83,27 @@ (defvar w3-display-frames nil "*Fetch frames - not optimal.") +(defvar w3-frame-labels '("FRAME(" . ")") + "Strings surrounding a frame name") + +(defvar w3-frame-regexp "FRAME(\\([^)]+\\))" + "Regexp for finding a frame hyperlink") + +(defvar w3-frameset-structure nil + "Frameset structure") + +(defvar w3-frameset-dimensions nil + "Frameset dimensions") + +(defvar w3-frame-name nil + "Frame name") + +(defvar w3-base-target nil + "Base target name") + +(defvar w3-target-window-distances nil + "Target window distances") + (defvar w3-do-incremental-display nil "*Whether to do incremental display of pages or not.") @@ -685,16 +706,12 @@ w3-form-elements url-current-callback-func url-current-content-length - url-current-file url-current-mime-encoding url-current-mime-headers url-current-mime-type url-current-mime-viewer - url-current-port + url-current-object url-current-referer - url-current-server - url-current-type - url-current-user w3-current-parse w3-current-isindex w3-current-last-buffer @@ -707,6 +724,10 @@ w3-form-labels w3-id-positions w3-imagemaps + w3-base-target + w3-target-window-distances + w3-frameset-structure + w3-frameset-dimensions ) "A list of variables that should be preserved when entering w3-mode.") @@ -735,6 +756,7 @@ (make-variable-buffer-local 'w3-base-alist) (make-variable-buffer-local 'w3-last-tag) (make-variable-buffer-local 'w3-last-fill-pos) +(make-variable-buffer-local 'w3-frame-name) (make-variable-buffer-local 'w3-active-faces) (make-variable-buffer-local 'w3-netscape-emulation-minor-mode) (make-variable-buffer-local 'w3-lynx-emulation-minor-mode) @@ -814,6 +836,7 @@ ;; Widget navigation (define-key w3-mode-map [tab] 'w3-widget-forward) +(define-key w3-mode-map "\t" 'w3-widget-forward) (define-key w3-mode-map "\M-\t" 'w3-widget-backward) (define-key w3-mode-map [backtab] 'w3-widget-backward) (define-key w3-mode-map [(shift tab)] 'w3-widget-backward) diff -r a0ec055d74dd -r a145efe76779 lisp/w3/w3-xemac.el --- a/lisp/w3/w3-xemac.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/w3/w3-xemac.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,7 +1,7 @@ ;;; w3-xemac.el --- XEmacs specific functions for emacs-w3 ;; Author: wmperry -;; Created: 1997/02/10 16:08:10 -;; Version: 1.14 +;; Created: 1997/02/17 23:09:24 +;; Version: 1.15 ;; Keywords: faces, help, mouse, hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -31,6 +31,7 @@ (require 'w3-widget) (require 'w3-menu) (require 'w3-forms) +(require 'w3-script) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Enhancements For XEmacs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -39,26 +40,14 @@ (interactive "e") (let* ((pt (event-point e)) (good (eq (event-window e) (selected-window))) - (widget (and good pt (number-or-marker-p pt) (widget-at pt))) - (link (and widget (or (widget-get widget 'href) - (widget-get widget 'name)))) - (form (and widget (widget-get widget :w3-form-data))) - (imag nil) - ) - (cond - (link (message "%s" (w3-widget-echo widget))) - (form - (cond - ((eq 'submit (w3-form-element-type form)) - (message "Submit form to %s" - (cdr-safe (assq 'action (w3-form-element-action form))))) - ((eq 'reset (w3-form-element-type form)) - (message "Reset form contents")) - (t - (message "Form entry (name=%s, type=%s)" (w3-form-element-name form) - (w3-form-element-type form))))) - (imag (message "Inlined image (%s)" (car imag))) - (t (message ""))))) + (mouse-events)) + (if (not (and good pt (number-or-marker-p pt))) + nil + (if (and inhibit-help-echo w3-track-mouse) + (widget-echo-help pt)) + (setq mouse-events (w3-script-find-event-handlers pt 'mouse)) + (if (assq 'onmouseover mouse-events) + (w3-script-evaluate-form (cdr (assq 'onmouseover mouse-events))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Functions to build menus of urls @@ -151,12 +140,10 @@ (defun w3-mode-version-specifics () "XEmacs specific stuff for w3-mode" (if (featurep 'mouse) - (cond - ((not w3-track-mouse) - (setq inhibit-help-echo nil)) - (inhibit-help-echo - (setq mode-motion-hook 'w3-mouse-handler)) - (t nil))) + (progn + (if (not w3-track-mouse) + (setq inhibit-help-echo nil)) + (setq mode-motion-hook 'w3-mouse-handler))) (if (eq (device-type) 'tty) nil (w3-add-toolbar-to-buffer)) diff -r a0ec055d74dd -r a145efe76779 lisp/w3/w3.el --- a/lisp/w3/w3.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/w3/w3.el Mon Aug 13 09:15:49 2007 +0200 @@ -1,7 +1,7 @@ ;;; w3.el --- Main functions for emacs-w3 on all platforms/versions ;; Author: wmperry -;; Created: 1997/02/13 23:05:56 -;; Version: 1.77 +;; Created: 1997/02/20 21:50:57 +;; Version: 1.82 ;; Keywords: faces, help, comm, news, mail, processes, mouse, hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -211,8 +211,10 @@ (fmt nil) ((cdr-safe (assoc "type" info)) (setq fmt (mm-type-to-file (cdr-safe (assoc "type" info)))) - (if fmt (setq fmt (concat "%s" (car fmt))) - (setq fmt (concat "%s" (url-file-extension url-current-file)))))) + (if fmt + (setq fmt (concat "%s" (car fmt))) + (setq fmt (concat "%s" (url-file-extension + (url-filename url-current-object))))))) (if (null view) (setq view 'indented-text-mode)) (cond @@ -222,7 +224,8 @@ mm-multipart-viewer))) (let ((bufnam (url-generate-new-buffer-name (file-name-nondirectory - (or url-current-file "Unknown"))))) + (or (url-filename url-current-object) + "Unknown"))))) (if (string= bufnam "") (setq bufnam (url-generate-new-buffer-name (url-view-url t)))) @@ -239,7 +242,7 @@ (let ((fname (url-generate-unique-filename fmt)) (proc nil)) (if (url-file-directly-accessible-p (url-view-url t)) - (make-symbolic-link url-current-file fname t) + (make-symbolic-link (url-filename url-current-object) fname t) (mule-write-region-no-coding-system (point-min) (point-max) fname)) (if (get-buffer url-working-buffer) (kill-buffer url-working-buffer)) @@ -458,7 +461,8 @@ (if (equal url "") (error "No document specified!")) ;; legal use for relative URLs ? (if (string-match "^www:[^/].*" url) - (setq url (concat (file-name-directory url-current-file) + (setq url (concat (file-name-directory (url-filename + url-current-object)) (substring url 4)))) ;; In the common case, this is probably cheaper than searching. (while (= (string-to-char url) ? ) @@ -472,8 +476,6 @@ (let ((x (url-view-url t)) (lastbuf (current-buffer)) (buf (url-buffer-visiting url))) - (and x (or (string= "file:nil" x) (string= "" x)) - (setq x nil)) (if (or (not buf) (cond ((not (equal (downcase (or url-request-method "GET")) "get")) t) @@ -497,8 +499,7 @@ (setq w3-last-buffer (get-buffer url-working-buffer))) (if (get-buffer url-working-buffer) (cond - ((and url-be-asynchronous - (not cached)) + ((and url-be-asynchronous (not cached)) (save-excursion (set-buffer url-working-buffer) (if x @@ -506,11 +507,7 @@ (setq w3-current-last-buffer lastbuf))) (t (w3-history-push x url) - (w3-sentinel lastbuf) - (if (string-match "#\\(.*\\)" url) - (progn - (push-mark (point) t) - (w3-find-specific-link (match-string 1 url)))))))) + (w3-sentinel lastbuf))))) (if w3-track-last-buffer (setq w3-last-buffer buf)) (let ((w3-notify (if (memq w3-notify '(newframe bully @@ -576,7 +573,10 @@ (setq w3-history-stack (list (cons url (current-time)))) (let ((node (memq (assoc referer w3-history-stack) w3-history-stack))) (if node - (setcdr node (list (cons url (current-time)))))))) + (setcdr node (list (cons url (current-time)))) + (setq w3-history-stack (append w3-history-stack + (list + (cons url (current-time))))))))) (defalias 'w3-add-urls-to-history 'w3-history-push) (defalias 'w3-backward-in-history 'w3-history-backward) @@ -634,15 +634,11 @@ (cur-links w3-current-links) (title (buffer-name)) (lastmod (or (cdr-safe (assoc "last-modified" - url-current-mime-headers)) - (and (member url-current-type '("file" "ftp")) - (nth 5 (url-file-attributes url))))) + url-current-mime-headers)))) (hdrs url-current-mime-headers) (info w3-current-metainfo)) (set-buffer (get-buffer-create url-working-buffer)) - (setq url-current-can-be-cached nil - url-current-type "about" - url-current-file "document") + (setq url-current-can-be-cached nil) (erase-buffer) (cond ((stringp lastmod) nil) @@ -804,67 +800,6 @@ (let ((url (url-get-url-at-point pt))) (and url (w3-fetch url)))) -;;;###autoload -(defun w3-batch-fetch () - "Fetch all the URLs on the command line and save them to files in -the current directory. The first argument after the -f w3-batch-fetch -on the command line should be a string specifying how to save the -information retrieved. If it is \"html\", then the page will be -unformatted when it is written to disk. If it is \"text\", then the -page will be formatted before it is written to disk. If it is -\"binary\" it will not mess with the file extensions, and just save -the data in raw binary format. If none of those, the default is -\"text\", and the first argument is treated as a normal URL." - (if (not w3-setup-done) (w3-do-setup)) - (if (not noninteractive) - (error "`w3-batch-fetch' is to be used only with -batch")) - (let ((fname "") - (curname "") - (x 0) - (args command-line-args-left) - (w3-strict-width 80) - (retrieval-function 'w3-fetch) - (file-format "text") - (header "") - (file-extn ".txt")) - (setq file-format (downcase (car args))) - (cond - ((string= file-format "html") - (message "Saving all text as raw HTML...") - (setq retrieval-function 'url-retrieve - file-extn ".html" - header "" - args (cdr args))) - ((string= file-format "binary") - (message "Saving as raw binary...") - (setq retrieval-function 'url-retrieve - file-extn "" - args (cdr args))) - ((string= file-format "text") - (setq header "Text from: %s\n---------------\n") - (message "Saving all text as formatted...") - (setq args (cdr args))) - (t - (setq header "Text from: %s\n---------------\n") - (message "Going with default, saving all text as formatted..."))) - (while args - (funcall retrieval-function (car args)) - (goto-char (point-min)) - (if buffer-read-only (toggle-read-only)) - (insert (format header (car args))) - (setq fname (url-basepath url-current-file t)) - (if (string= file-extn "") nil - (setq fname (url-file-extension fname t))) - (if (string= (url-strip-leading-spaces fname) "") - (setq fname "root")) - (setq curname fname) - (while (file-exists-p (concat curname file-extn)) - (setq curname (concat fname x) - x (1+ x))) - (setq fname (concat curname file-extn)) - (write-region (point-min) (point-max) fname) - (setq args (cdr args))))) - (defun w3-fix-spaces (x) "Remove spaces/tabs at the beginning of a string, and convert newlines into spaces." @@ -915,7 +850,6 @@ "View this document's source" (interactive "P") (let* ((url (if under (w3-view-this-url) (url-view-url t))) - (fil (if under nil url-current-file)) (src (cond ((null url) @@ -928,7 +862,6 @@ (prog2 (url-retrieve url) (buffer-string) - (setq fil (or fil url-current-file)) (kill-buffer (current-buffer)))))) (tmp (url-generate-new-buffer-name url))) (if (and url (get-buffer url)) @@ -1091,10 +1024,12 @@ (save-excursion (set-buffer url-working-buffer) (let ((cont w3-default-continuation) - (extn (url-file-extension url-current-file))) + (extn (url-file-extension + (url-filename url-current-object)))) (if (assoc extn url-uncompressor-alist) (setq extn (url-file-extension - (substring url-current-file 0 (- (length extn)))))) + (substring (url-filename url-current-object) + 0 (- (length extn)))))) (if w3-source (setq url-current-mime-viewer '(("viewer" . w3-source)))) (if (not url-current-mime-viewer) @@ -1117,15 +1052,19 @@ "Do a find-file on the currently viewed html document if it is a file: or ftp: reference" (interactive) - (cond - ((and (or (null url-current-type) (equal url-current-type "file")) - (eq major-mode 'w3-mode)) - (find-file url-current-file)) - ((equal url-current-type "ftp") - (find-file - (format "/%s@%s:%s" url-current-user url-current-server - url-current-file))) - (t (message "Sorry, I can't get that file so you can alter it.")))) + (or url-current-object + (error "Not a URL-based buffer")) + (let ((type (url-type url-current-object))) + (cond + ((equal type "file") + (find-file (url-filename url-current-object))) + ((equal type "ftp") + (find-file + (format "/%s@%s:%s" + (url-user url-current-object) + (url-host url-current-object) + (url-filename url-current-object)))) + (t (message "Sorry, I can't get that file so you can alter it."))))) (defun w3-insert-this-url (pref-arg) "Insert the current url in another buffer, with prefix ARG, @@ -1230,7 +1169,8 @@ (if (not url-current-mime-type) (setq url-current-mime-type (or (mm-extension-to-mime (url-file-extension - url-current-file)) + (url-filename + url-current-object))) "text/html"))))) (if (not (string-match "^www:" (or (url-view-url t) ""))) (w3-convert-code-for-mule url-current-mime-type)) @@ -1570,6 +1510,7 @@ (defun w3-generate-error (type data) ;; Generate an HTML error buffer for error TYPE with data DATA. + (setq url-current-mime-type "text/html") (cond ((equal type "nofile") (let ((error (save-excursion @@ -1645,15 +1586,10 @@ (setq base (url-generic-parse-url base))) (insert-buffer buffer) (if (not base) - (setq url-current-type "file" - url-current-server nil - url-current-file (buffer-file-name buffer)) - (setq url-current-object base - url-current-type (url-type base) - url-current-user (url-user base) - url-current-port (url-port base) - url-current-server (url-host base) - url-current-file (url-filename base))))) + (setq url-current-object + (url-generic-parse-url (concat "file:" + (buffer-file-name buffer)))) + (setq url-current-object base)))) (defun w3-internal-url (url) ;; Handle internal urls (previewed buffers, etc) @@ -1662,9 +1598,6 @@ (let ((type (url-match url 1)) (data (url-match url 2))) (set-buffer (get-buffer-create url-working-buffer)) - (setq url-current-type "www" - url-current-server type - url-current-file data) (cond ((equal type "preview") ; Previewing a document (if (get-buffer data) ; Buffer still exists @@ -1692,7 +1625,7 @@ (defun w3-default-local-file() "Use find-file to open the local file" - (w3-ff url-current-file)) + (w3-ff (url-filename url-current-object))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Mode definition ;;; @@ -1876,12 +1809,7 @@ (w3-fetch (completing-read "Choose an address: " (mapcar 'list possible) nil t (car possible)))))) - (message "Could not automatically determine authors address, sorry.") - (sit-for 1) - (w3-fetch (concat "mailto:" - (read-string "Email address: " - (if url-current-server - (concat "@" url-current-server)))))))) + (message "Could not automatically determine authors address, sorry.")))) (defun w3-kill-emacs-func () "Routine called when exiting emacs. Do miscellaneous clean up." @@ -2191,13 +2119,14 @@ (urlobj (url-generic-parse-url url)) (url-working-buffer (generate-new-buffer (concat " *" url " download*"))) - (stub-fname (url-remove-compressed-extensions - (url-basepath (or (url-filename urlobj) "") t))) - (fname (read-file-name "Filename to save as: " - (or mm-download-directory "~/") - stub-fname - nil - stub-fname))) + (stub-fname (url-basepath (or (url-filename urlobj) "") t)) + (dir (or mm-download-directory "~/")) + (fname (expand-file-name + (read-file-name "Filename to save as: " + dir + stub-fname + nil + stub-fname) dir))) (setq-default url-be-asynchronous t) (save-excursion (set-buffer url-working-buffer) @@ -2292,8 +2221,15 @@ (substring link-at-point 0 17) "...")) "): ") "Link: ") links-alist nil t)) - (if (setq choice (try-completion choice links-alist)) - (w3-fetch (cdr (assoc choice links-alist)))))) + (let ((match (try-completion choice links-alist))) + (cond + ((eq t match) ; We have an exact match + (setq choice (cdr (assoc choice links-alist)))) + ((stringp match) + (setq choice (cdr (assoc match links-alist)))) + (t (setq choice nil))) + (if choice + (w3-fetch choice))))) (defun w3-mode () "Mode for viewing HTML documents. If called interactively, will @@ -2320,7 +2256,7 @@ inhibit-read-only nil truncate-lines t mode-line-format w3-modeline-format) - (if (and w3-current-isindex (equal url-current-type "http")) + (if w3-current-isindex (setq mode-line-process "-Searchable"))))) (require 'mm) diff -r a0ec055d74dd -r a145efe76779 lisp/x11/x-menubar.el --- a/lisp/x11/x-menubar.el Mon Aug 13 09:15:13 2007 +0200 +++ b/lisp/x11/x-menubar.el Mon Aug 13 09:15:49 2007 +0200 @@ -554,7 +554,7 @@ :selected (eq browse-url-browser-function 'browse-url-grail)] ) "-----" - ["Edit Faces..." edit-faces t] + ["Edit Faces..." cu-edit-faces t] ("Font" :filter font-menu-family-constructor) ("Size" :filter font-menu-size-constructor) ("Weight" :filter font-menu-weight-constructor) @@ -610,7 +610,7 @@ ["Splash" xemacs-splash-buffer t]) "-----" ("XEmacs FAQ" - ["FAQ" xemacs-local-faq t] + ["FAQ (local)" xemacs-local-faq t] ["FAQ via WWW" xemacs-www-faq t] ["Home Page" xemacs-www-page t]) ("Samples" @@ -1037,6 +1037,12 @@ ;;; The Options menu +(defvar options-save-faces nil + "if t, save-options will save all the face information. +Set to nil to avoid this. This is recommended on XEmacs 19.15 +and above as we have a much more powerful (read: working) way +of changing and saving faces via cu-edit-faces.el & custom.el.") + (defconst options-menu-saved-forms ;; This is really quite a kludge, but it gets the job done. ;; @@ -1163,29 +1169,30 @@ ;; Setting this in lisp conflicts with X resources. Bad move. --Stig ;; (list 'set-face-font ''default (face-font-name 'default)) ;; (list 'set-face-font ''modeline (face-font-name 'modeline)) - - (cons 'progn - (mapcar #'(lambda (face) - `(make-face ',face)) - (face-list))) + (if options-save-faces + (cons 'progn + (mapcar #'(lambda (face) + `(make-face ',face)) + (face-list)))) - (cons 'progn - (apply 'nconc - (mapcar - #'(lambda (face) - (delq nil - (mapcar - #'(lambda (property) - (if (specifier-spec-list - (face-property face property)) - `(add-spec-list-to-specifier - (face-property ',face ',property) - ',(save-options-specifier-spec-list - face property)))) - (delq 'display-table - (copy-sequence - built-in-face-specifiers))))) - (face-list)))) + (if options-save-faces + (cons 'progn + (apply 'nconc + (mapcar + #'(lambda (face) + (delq nil + (mapcar + #'(lambda (property) + (if (specifier-spec-list + (face-property face property)) + `(add-spec-list-to-specifier + (face-property ',face ',property) + ',(save-options-specifier-spec-list + face property)))) + (delq 'display-table + (copy-sequence + built-in-face-specifiers))))) + (face-list))))) ;; Mule-specific: (if (featurep 'mule) diff -r a0ec055d74dd -r a145efe76779 lwlib/xlwscrollbar.c --- a/lwlib/xlwscrollbar.c Mon Aug 13 09:15:13 2007 +0200 +++ b/lwlib/xlwscrollbar.c Mon Aug 13 09:15:49 2007 +0200 @@ -1,5 +1,6 @@ /* Implements a lightweight scrollbar widget. Copyright (C) 1992, 1993, 1994 Lucid, Inc. + Copyright (C) 1997 Sun Microsystems, Inc. This file is part of the Lucid Widget Library. @@ -19,6 +20,7 @@ Boston, MA 02111-1307, USA. */ /* Created by Douglas Keller */ +/* Lots of hacking by Martin Buchholz */ /* * Athena-style scrollbar button bindings added on Sun Dec 24 22:03:57 1995 @@ -61,7 +63,7 @@ * XmNtoBottomCallback * XmNdragCallback * - * XmNknobStyle - values can be: "plain" or "dimple" + * XmNsliderStyle - values can be: "plain" or "dimple" * XmNarrowPosition - values can be: "opposite" or "same" * */ @@ -86,33 +88,23 @@ #define SS_MIN 8 -#define ARROW_UP 0 -#define ARROW_DOWN 1 -#define ARROW_LEFT 2 -#define ARROW_RIGHT 3 - -#define ARM_NONE 0 -#define ARM_KNOB 1 -#define ARM_UP 2 -#define ARM_DOWN 3 -#define ARM_PAGEUP 4 -#define ARM_PAGEDOWN 5 +typedef enum +{ + BUTTON_NONE, + BUTTON_SLIDER, + BUTTON_UP_ARROW, + BUTTON_DOWN_ARROW, + BUTTON_TROUGH_ABOVE, + BUTTON_TROUGH_BELOW +} button_where; -#define BUTTON_NONE 0 -#define BUTTON_KNOB 1 -#define BUTTON_UP_ARROW 2 -#define BUTTON_DOWN_ARROW 3 -#define BUTTON_TROUGH_ABOVE 4 -#define BUTTON_TROUGH_BELOW 5 +typedef enum +{ + SLIDER_PLAIN, + SLIDER_DIMPLE +} SliderStyle; -#define KNOB_PLAIN 0 -#define KNOB_DIMPLE 1 - -/************************************************************************ -** -** Resources -** -*/ +/*-------------------------- Resources ----------------------------------*/ #define offset(field) XtOffset(XlwScrollBarWidget, field) static XtResource resources[] = { @@ -189,33 +181,23 @@ { XmNdragCallback, XmCDragCallback, XtRCallback, sizeof(XtPointer), offset(sb.dragCBL), XtRCallback, NULL}, + /* "knob" is obsolete; use "slider" instead. */ + { XmNsliderStyle, XmCSliderStyle, XtRString, sizeof(char *), + offset(sb.sliderStyle), XtRImmediate, NULL}, { XmNknobStyle, XmCKnobStyle, XtRString, sizeof(char *), - offset(sb.knobStyle), XtRImmediate, NULL}, + offset(sb.sliderStyle), XtRImmediate, NULL}, { XmNarrowPosition, XmCArrowPosition, XtRString, sizeof(char *), offset(sb.arrowPosition), XtRImmediate, NULL}, }; -/************************************************************************ -** -** Prototypes -** -*/ +/*-------------------------- Prototypes ---------------------------------*/ -/* -** Actions -*/ -static void Select(Widget w, XEvent *event, String *parms, Cardinal *num_parms); -static void PageUpOrLeft(Widget w, XEvent *event, String *parms, Cardinal *num_parms); -static void PageDownOrRight(Widget w, XEvent *event, String *parms, Cardinal *num_parms); -static void Drag(Widget w, XEvent *event, String *parms, Cardinal *num_parms); -static void Release(Widget w, XEvent *event, String *parms, Cardinal *num_parms); -static void Jump(Widget w, XEvent *event, String *parms, Cardinal *num_parms); -static void Abort(Widget w, XEvent *event, String *parms, Cardinal *num_parms); +/* Actions */ +typedef void Action(Widget w, XEvent *event, String *parms, Cardinal *num_parms); +static Action Select, PageUpOrLeft, PageDownOrRight, Drag, Release, Jump, Abort; -/* -** Methods -*/ +/* Methods */ static void Initialize(Widget treq, Widget tnew, ArgList args, Cardinal *num_args); static Boolean SetValues(Widget current, Widget request, Widget nw, ArgList args, Cardinal *num_args); static void Destroy(Widget widget); @@ -223,46 +205,32 @@ static void Resize(Widget widget); static void Realize(Widget widget, XtValueMask *valuemask, XSetWindowAttributes *attr); -/* -** Private -*/ - +/* Private */ -/************************************************************************ -** -** Actions Table -** -*/ -static XtActionsRec actions[] = { - {"Select", Select}, - {"PageDownOrRight", PageDownOrRight}, - {"PageUpOrLeft", PageUpOrLeft}, - {"Drag", Drag}, - {"Release", Release}, - {"Jump", Jump}, - {"Abort", Abort}, +/*-------------------------- Actions Table ------------------------------*/ +static XtActionsRec actions[] = +{ + {"Select", Select}, + {"PageDownOrRight", PageDownOrRight}, + {"PageUpOrLeft", PageUpOrLeft}, + {"Drag", Drag}, + {"Release", Release}, + {"Jump", Jump}, + {"Abort", Abort}, }; -/************************************************************************ -** -** Default Translation Table -** -*/ +/*--------------------- Default Translation Table -----------------------*/ static char default_translations[] = - ": Select()\n" - ": Drag()\n" - ": Release()\n" - ": Jump()\n" - ": Drag()\n" - ": Release()\n" - "Delete: Abort()" + ": Select()\n" + ": Drag()\n" + ": Release()\n" + ": Jump()\n" + ": Drag()\n" + ": Release()\n" + "Delete: Abort()" ; -/************************************************************************ -** -** Class record initalization -** -*/ +/*------------------- Class record initialization -----------------------*/ XlwScrollBarClassRec xlwScrollBarClassRec = { /* core_class fields */ { @@ -305,11 +273,7 @@ WidgetClass xlwScrollBarWidgetClass = (WidgetClass) &xlwScrollBarClassRec; -/************************************************************************ -** -** Debug functions -** -*/ +/*-------------------------- Debug Functions ----------------------------*/ #ifdef SHOW_CLEAR static void @@ -329,15 +293,13 @@ static void check(XlwScrollBarWidget w) { - int height; - - height= widget_h (w); - if (w->sb.showArrows) height -= (2 * arrow_h (w)); + int height = widget_h (w); + if (w->sb.showArrows) + height -= (2 * arrow_h (w)); if ((w->sb.above + w->sb.ss + w->sb.below > height) || (w->sb.value < w->sb.minimum) || - (w->sb.value > w->sb.maximum - w->sb.sliderSize) - ) + (w->sb.value > w->sb.maximum - w->sb.sliderSize)) { printf("above=%d ss=%d below=%d height=%d\n", w->sb.above, w->sb.ss, w->sb.below, height); @@ -353,11 +315,7 @@ # define CHECK(w) #endif -/************************************************************************ -** -** Static functions -** -*/ +/*-------------------------- Static functions ---------------------------*/ static void call_callbacks (XlwScrollBarWidget w, int reason, @@ -437,9 +395,8 @@ } } -/* -** Widget sizes minus the shadow and highlight area -*/ +/* Widget sizes minus the shadow and highlight area */ + static int widget_x (XlwScrollBarWidget w) { @@ -455,41 +412,26 @@ static int widget_w (XlwScrollBarWidget w) { - int width, x = w->sb.shadowThickness; - - width = VERT (w) ? w->core.width : w->core.height; - - if (width <= (2 * x)) - return 1; - else - return width - (2 * x); + int x = w->sb.shadowThickness; + int width = (VERT (w) ? w->core.width : w->core.height) - (2 * x); + return width > 1 ? width : 1; } static int widget_h (XlwScrollBarWidget w) { - int height, y = w->sb.shadowThickness; - - height = VERT (w) ? w->core.height : w->core.width; + int y = w->sb.shadowThickness; + int height = (VERT (w) ? w->core.height : w->core.width) - (2 * y); - if (height <= (2 * y)) - return 1; - else - return height - (2 * y); + return height > 1 ? height : 1; } static int arrow_h (XlwScrollBarWidget w) { - int width, height; - - width = widget_w (w); - height= widget_h (w); - - if (width > ((height / 2) - (SS_MIN / 2) - 1)) - return (height / 2) - (SS_MIN / 2) - 1 ; - else - return width; + int width = widget_w (w); + int minimum_size = ((widget_h (w) - SS_MIN) / 2) - 1; + return minimum_size < width ? minimum_size : width; } static int @@ -504,29 +446,29 @@ return VERT (w) ? event->xbutton.y : event->xbutton.x; } -/* -** Safe addition and subtraction -*/ -static int -safe_add (int a, int b) +/* Safe addition and subtraction */ +static void +increment_value (XlwScrollBarWidget w, int diff) { - if (a > 0 && INT_MAX - a < b) return INT_MAX; - else return a + b; + w->sb.value = w->sb.maximum - diff < w->sb.value ? + w->sb.maximum : + w->sb.value + diff; } -static int -safe_subtract (int a, int b) +static void +decrement_value (XlwScrollBarWidget w, int diff) { - if (a < 0 && -(INT_MIN - a) < b) return INT_MIN; - else return a - b; + w->sb.value = w->sb.minimum + diff > w->sb.value ? + w->sb.minimum : + w->sb.value - diff; } -static int -knob_style (XlwScrollBarWidget w) +static SliderStyle +slider_style (XlwScrollBarWidget w) { - return w->sb.knobStyle && w->sb.knobStyle[0] == 'd' ? - KNOB_DIMPLE : - KNOB_PLAIN; + return w->sb.sliderStyle && w->sb.sliderStyle[0] == 'd' ? + SLIDER_DIMPLE : + SLIDER_PLAIN; } static Boolean @@ -535,9 +477,7 @@ return w->sb.arrowPosition && w->sb.arrowPosition[0] == 's' ? True : False; } -/* -** GC and Pixel allocation -*/ +/*-------------------------- GC and Pixel allocation --------------------*/ static GC get_gc (XlwScrollBarWidget w, Pixel fg, Pixel bg, Pixmap pm) { @@ -559,8 +499,8 @@ values.background = bg; values.fill_style = FillOpaqueStippled; values.stipple = pm; - mask = GCForeground | GCBackground | - (pm == None ? 0 : GCStipple | GCFillStyle); + mask = GCForeground | GCBackground | + (pm == None ? 0 : GCStipple | GCFillStyle); return XtGetGC((Widget) w, mask, &values); } @@ -716,7 +656,7 @@ * really in color but just short on color cells -- We want the * following behavior, which has been empirically determined to * work well for all fg/bg combinations in mono: If the trough - * and thumb are BOTH black, then use a white top shadow and a + * and slider are BOTH black, then use a white top shadow and a * grey bottom shadow, otherwise use a grey top shadow and a * black bottom shadow. */ @@ -724,7 +664,7 @@ Pixel white = WhitePixelOfScreen (DefaultScreenOfDisplay (XtDisplay (w))); Pixel black = BlackPixelOfScreen (DefaultScreenOfDisplay (XtDisplay (w))); - /* Note: core.background_pixel is the color of the thumb ... */ + /* Note: core.background_pixel is the color of the slider ... */ if (w->core.background_pixel == black && w->sb.troughColor == black) @@ -759,9 +699,7 @@ } } -/* -** Draw 3d border -*/ +/*-------------------------- Draw 3D Border -----------------------------*/ static void draw_shadows (Display *dpy, Drawable d, GC shine_gc, GC shadow_gc, int x, int y, int width, int height, int shadowT) @@ -798,20 +736,18 @@ XDrawSegments (dpy, d, shadow_gc, shadow, shadowT * 2); } -/* -** Draw 3d arrows, left, up, down, and right -*/ +/*------------------ Draw 3D Arrows: left, up, down, right --------------*/ static int make_vert_seg (XSegment *seg, int x1, int y1, int x2, int y2, int shadowT) { int i; - for (i=0; ix1 = x1; + seg->y1 = y1++; + seg->x2 = x2; + seg->y2 = y2++; } return shadowT; } @@ -821,12 +757,12 @@ { int i; - for (i=0; ix1 = x1++; + seg->y1 = y1; + seg->x2 = x2++; + seg->y2 = y2; } return shadowT; } @@ -843,18 +779,18 @@ if (shadowT > (width / 2)) shadowT = (width / 2); if (shadowT > (height / 2)) shadowT = (height / 2); - if (shadowT <= 0) shadowT = 0; + if (shadowT < 0) shadowT = 0; /* / */ make_vert_seg (shine, - x, y + height - shadowT - 1, + x, y + height - shadowT - 1, x + mid, y, shadowT); /* _\ */ make_vert_seg (shadow, - x, y + height - shadowT - 1, + x, y + height - shadowT - 1, x + width - 1, y + height - shadowT - 1, shadowT); make_vert_seg (shadow + shadowT, - x + mid, y, + x + mid, y, x + width - 1, y + height - shadowT - 1, shadowT); triangle[0].x = x; @@ -876,21 +812,20 @@ { XSegment shine[10], shadow[10]; XPoint triangle[3]; - int mid; - mid = width / 2; + int mid = width / 2; if (shadowT > (width / 2)) shadowT = (width / 2); if (shadowT > (height / 2)) shadowT = (height / 2); - if (shadowT <= 0) shadowT = 0; + if (shadowT < 0) shadowT = 0; /* / */ make_hor_seg (shine, - x, y + mid, + x, y + mid, x + width - shadowT - 1, y, shadowT); /* \| */ make_hor_seg (shadow, - x, y + mid, + x, y + mid, x + width - shadowT - 1, y + height - 1, shadowT); make_hor_seg (shadow + shadowT, x + width - shadowT - 1, y, @@ -921,19 +856,19 @@ if (shadowT > (width / 2)) shadowT = (width / 2); if (shadowT > (height / 2)) shadowT = (height / 2); - if (shadowT <= 0) shadowT = 0; + if (shadowT < 0) shadowT = 0; /* \- */ make_vert_seg (shine, - x, y, + x, y, x + mid, y + height - shadowT - 1, shadowT); make_vert_seg (shine + shadowT, - x, y, + x, y, x + width - 1, y, shadowT); /* / */ make_vert_seg (shadow, x + width - 1, y, - x + mid, y + height - shadowT - 1, shadowT); + x + mid, y + height - shadowT - 1, shadowT); triangle[0].x = x; triangle[0].y = y; @@ -960,23 +895,23 @@ if (shadowT > (width / 2)) shadowT = (width / 2); if (shadowT > (height / 2)) shadowT = (height / 2); - if (shadowT <= 0) shadowT = 0; + if (shadowT < 0) shadowT = 0; /* |\ */ make_hor_seg (shine, - x, y, + x, y, x + width - shadowT - 1, y + mid, shadowT); make_hor_seg (shine + shadowT, x, y, - x, y + height -1, shadowT); + x, y + height - 1, shadowT); /* / */ make_hor_seg (shadow, - x, y + height -1, + x, y + height - 1, x + width - shadowT - 1, y + mid, shadowT); triangle[0].x = x + 1; triangle[0].y = y + height - 1; - triangle[1].x = x + width - 1; + triangle[1].x = x + width - 1; triangle[1].y = y + mid; triangle[2].x = x + 1; triangle[2].y = y; @@ -995,9 +930,7 @@ XDrawArc (dpy, win, shadow, x, y, width, height, 45*64, -179*64); } -/* -** Scrollbar values -> pixels, pixels -> scrollbar values -*/ +/*------- Scrollbar values -> pixels, pixels -> scrollbar values --------*/ static void seg_pixel_sizes (XlwScrollBarWidget w, int *above_return, @@ -1019,14 +952,14 @@ above = ((height * value + fuz) / total); below = ((height) - (ss + above)); - /* Dont' let knob get smaller than SS_MIN */ + /* Don't let slider get smaller than SS_MIN */ if (ss < SS_MIN) { /* add a percent amount for integer rounding */ float tmp = ((((float) (SS_MIN - ss) * (float) value)) / total) + 0.5; above -= (int) tmp; - ss = SS_MIN; + ss = SS_MIN; below = ((height) - (ss + above)); if (above < 0) @@ -1071,8 +1004,11 @@ if (w->sb.value < w->sb.minimum) w->sb.value = w->sb.minimum; - if (w->sb.value > w->sb.maximum - w->sb.sliderSize) - w->sb.value = w->sb.maximum - w->sb.sliderSize; + if (w->sb.value > w->sb.maximum) + w->sb.value = w->sb.maximum; + + if (w->sb.sliderSize > w->sb.maximum - w->sb.value) + w->sb.sliderSize = w->sb.maximum - w->sb.value; } static int @@ -1081,8 +1017,9 @@ float total, height, fuz; int value, ss; - height= widget_h (w); - if (w->sb.showArrows) height -= (2 * arrow_h (w)); + height = widget_h (w); + if (w->sb.showArrows) + height -= (2 * arrow_h (w)); total = w->sb.maximum - w->sb.minimum; fuz = height / 2; @@ -1114,23 +1051,13 @@ redraw_dimple (XlwScrollBarWidget w, Display *dpy, Window win, int x, int y, int width, int height) { - GC shine, shadow; - int shadowT, size; - - if (KNOB_DIMPLE == knob_style (w)) + if (SLIDER_DIMPLE == slider_style (w)) { - if (w->sb.armed == ARM_KNOB) - { - shine = w->sb.bottomShadowGC; - shadow = w->sb.topShadowGC; - } - else - { - shine = w->sb.topShadowGC; - shadow = w->sb.bottomShadowGC; - } - - shadowT = w->sb.shadowThickness; + int size; + int slider_p = (w->sb.armed == ARM_SLIDER); + GC shine = slider_p ? w->sb.bottomShadowGC : w->sb.topShadowGC; + GC shadow = slider_p ? w->sb.topShadowGC : w->sb.bottomShadowGC; + int shadowT = w->sb.shadowThickness; x += shadowT; y += shadowT; @@ -1153,59 +1080,58 @@ } static void -draw_knob (XlwScrollBarWidget w, int above, int ss, int below) +draw_slider (XlwScrollBarWidget w, int above, int ss, int below) { Display *dpy = XtDisplay ((Widget) w); Window win = XtWindow ((Widget) w); - int x, y, width, height; - int shadowT; - x = widget_x (w); - y = widget_y (w); - width = widget_w (w); - height = widget_h (w); - - shadowT = w->sb.shadowThickness; + int x = widget_x (w); + int y = widget_y (w); + int width = widget_w (w); + int height = widget_h (w); + int shadowT = w->sb.shadowThickness; + int vert_p = VERT (w); if (shadowT > (width / 2)) shadowT = (width / 2); if (shadowT > (height / 2)) shadowT = (height / 2); - if (shadowT <= 0) return; + if (shadowT < 0) shadowT = 0; - if (w->sb.showArrows && !arrow_same_end (w)) y += arrow_h (w); + if (w->sb.showArrows && !arrow_same_end (w)) + y += arrow_h (w); - /* trough above knob */ + /* trough above slider */ if (above > 0) { - if (VERT (w)) + if (vert_p) XClearArea (dpy, win, x, y, width, above, False); else XClearArea (dpy, win, y, x, above, width, False); } - /* knob */ - if (VERT (w)) + /* slider */ + if (vert_p) { draw_shadows (dpy, win, w->sb.topShadowGC, w->sb.bottomShadowGC, x, y + above, width, ss, shadowT); - XFillRectangle (dpy, win, - w->sb.backgroundGC, - x+shadowT, y + above + shadowT, width-2*shadowT, ss-2*shadowT); + XFillRectangle (dpy, win, w->sb.backgroundGC, + x+shadowT, y + above + shadowT, + width-2*shadowT, ss-2*shadowT); redraw_dimple (w, dpy, win, x, y + above, width, ss); } else { draw_shadows (dpy, win, w->sb.topShadowGC, w->sb.bottomShadowGC, y + above, x, ss, width, shadowT); - XFillRectangle (dpy, win, - w->sb.backgroundGC, - y + above + shadowT, x+shadowT, ss-2*shadowT, width-2*shadowT); + XFillRectangle (dpy, win, w->sb.backgroundGC, + y + above + shadowT, x+shadowT, + ss-2*shadowT, width-2*shadowT); redraw_dimple (w, dpy, win, y + above, x, ss, width); } - /* trough below knob */ + /* trough below slider */ if (below > 0) { - if (VERT (w)) + if (vert_p) XClearArea (dpy, win, x, y + above + ss, width, below, False); else XClearArea (dpy, win, y + above + ss, x, below, width, False); @@ -1219,35 +1145,22 @@ { Display *dpy = XtDisplay ((Widget) w); Window win = XtWindow ((Widget) w); - GC bg, shine, shadow; - int x, y, width, height, arrow_height, shadowT; - - x = widget_x (w); - y = widget_y (w); - width = widget_w (w); - height = widget_h (w); - arrow_height = arrow_h (w); - shadowT = w->sb.shadowThickness; - bg = w->sb.backgroundGC; + int x = widget_x (w); + int y = widget_y (w); + int width = widget_w (w); + int height = widget_h (w); + int shadowT = w->sb.shadowThickness; + int arrow_height = arrow_h (w); - if (armed) - { - shine = w->sb.bottomShadowGC; - shadow = w->sb.topShadowGC; - } - else - { - shine = w->sb.topShadowGC; - shadow = w->sb.bottomShadowGC; - } + GC bg = w->sb.backgroundGC; + GC shine = armed ? w->sb.bottomShadowGC : w->sb.topShadowGC; + GC shadow = armed ? w->sb.topShadowGC : w->sb.bottomShadowGC; if (VERT (w)) { if (arrow_same_end (w)) - { - y += height - 2 * arrow_h (w) + 2; - } + y += height - 2 * arrow_height; if (clear_behind) XClearArea (dpy, win, x, y, width, arrow_height + 1, False); draw_arrow_up (dpy, win, bg, shine, shadow, @@ -1257,9 +1170,7 @@ else { if (arrow_same_end (w)) - { - y += height - 2 * arrow_h (w); - } + y += height - 2 * arrow_height; if (clear_behind) XClearArea (dpy, win, y, x, arrow_height + 1, height, False); draw_arrow_left (dpy, win, bg, shine, shadow, @@ -1273,28 +1184,17 @@ { Display *dpy = XtDisplay ((Widget) w); Window win = XtWindow ((Widget) w); - GC bg, shine, shadow; - int x, y, width, height, arrow_height, shadowT; - - x = widget_x (w); - y = widget_y (w); - width = widget_w (w); - height = widget_h (w); - arrow_height = arrow_h (w); - shadowT = w->sb.shadowThickness; - bg = w->sb.backgroundGC; + int x = widget_x (w); + int y = widget_y (w); + int width = widget_w (w); + int height = widget_h (w); + int shadowT = w->sb.shadowThickness; + int arrow_height = arrow_h (w); - if (armed) - { - shine = w->sb.bottomShadowGC; - shadow = w->sb.topShadowGC; - } - else - { - shine = w->sb.topShadowGC; - shadow = w->sb.bottomShadowGC; - } + GC bg = w->sb.backgroundGC; + GC shine = armed ? w->sb.bottomShadowGC : w->sb.topShadowGC; + GC shadow = armed ? w->sb.topShadowGC : w->sb.bottomShadowGC; if (VERT (w)) { @@ -1323,48 +1223,49 @@ { Display *dpy = XtDisplay ((Widget) w); Window win = XtWindow ((Widget) w); - int x, y, width, height, shadowT, tmp; - - x = widget_x (w); - y = widget_y (w); - width = widget_w (w); - height = widget_h (w); - shadowT = w->sb.shadowThickness; if (w->sb.showArrows) { - if (region == NULL || XRectInRegion (region, x, y, width, width)) + if (region == NULL) { - redraw_up_arrow (w, False, behind_arrows); - } - if (VERT (w)) - { - y = y + height - width + 1; + redraw_up_arrow (w, False, behind_arrows); + redraw_down_arrow (w, False, behind_arrows); } else { - tmp = y; - y = x; - x = tmp + height - width + 1; - } - if (region == NULL || XRectInRegion (region, x, y, width, width)) - { - redraw_down_arrow (w, False, behind_arrows); + int x = widget_x (w); + int y = widget_y (w); + int width = widget_w (w); + int height = widget_h (w); + int arrow_height = arrow_h (w); + int ax = x, ay = y; + + if (arrow_same_end (w)) + { + if (VERT (w)) + ay = y + height - arrow_height - arrow_height; + else + ax = x + height - arrow_height - arrow_height; + } + if (XRectInRegion (region, ax, ay, width, width)) + redraw_up_arrow (w, False, behind_arrows); + + if (VERT (w)) + ay = y + height - arrow_height; + else + ax = x + height - arrow_height; + if (XRectInRegion (region, ax, ay, width, width)) + redraw_down_arrow (w, False, behind_arrows); } } - draw_shadows (dpy, win, w->sb.bottomShadowGC, w->sb.topShadowGC, - 0, 0, w->core.width, w->core.height, shadowT); + draw_shadows (dpy, win, w->sb.bottomShadowGC, w->sb.topShadowGC, 0, 0, + w->core.width, w->core.height, w->sb.shadowThickness); - draw_knob (w, w->sb.above, w->sb.ss, w->sb.below); - + draw_slider (w, w->sb.above, w->sb.ss, w->sb.below); } -/************************************************************************ -** -** Method functions -** -*/ +/*-------------------------- Method Functions ---------------------------*/ static void Initialize (Widget treq, Widget tnew, ArgList args, Cardinal *num_args) @@ -1374,8 +1275,6 @@ Display *dpy = XtDisplay ((Widget) w); Window win = RootWindowOfScreen (DefaultScreenOfDisplay (dpy)); - DBUG (fprintf (stderr, "Initialize\n")); - if (request->core.width == 0) w->core.width += (VERT (w) ? 12 : 25); if (request->core.height == 0) w->core.height += (VERT (w) ? 25 : 12); @@ -1386,6 +1285,7 @@ w->sb.ss = 0; w->sb.below = 0; w->sb.armed = ARM_NONE; + w->sb.forced_scroll = FORCED_SCROLL_NONE; if (w->sb.shadowThickness > 5) w->sb.shadowThickness = 5; @@ -1417,8 +1317,6 @@ XlwScrollBarWidget w = (XlwScrollBarWidget) widget; Display *dpy = XtDisplay ((Widget) w); - DBUG (fprintf (stderr, "Destroy\n")); - XtReleaseGC (widget, w->sb.bottomShadowGC); XtReleaseGC (widget, w->sb.topShadowGC); XtReleaseGC (widget, w->sb.backgroundGC); @@ -1426,7 +1324,10 @@ XFreePixmap (dpy, w->sb.grayPixmap); if (w->sb.timerActive) - XtRemoveTimeOut (w->sb.timerId); + { + XtRemoveTimeOut (w->sb.timerId); + w->sb.timerActive = False; /* Should be a no-op, but you never know */ + } } static void @@ -1437,8 +1338,6 @@ Window win; XSetWindowAttributes win_attr; - DBUG (fprintf (stderr, "Realize\n")); - (*coreClassRec.core_class.realize)(widget, valuemask, attr); win = XtWindow ((Widget) w); @@ -1448,7 +1347,7 @@ XSetWindowBackground (dpy, win, w->sb.troughColor); /* Change bit gravity so widget is not cleared on resize */ - win_attr.bit_gravity = NorthWestGravity; + win_attr.bit_gravity = NorthWestGravity; XChangeWindowAttributes (dpy, win, CWBitGravity , &win_attr); } @@ -1466,11 +1365,17 @@ seg_pixel_sizes (w, &w->sb.above, &w->sb.ss, &w->sb.below); - /*redraw_everything(w, NULL, True);*/ + /* redraw_everything (w, NULL, True); */ w->sb.fullRedrawNext = True; /* Force expose event */ - XClearArea (dpy, win, widget_x(w), widget_y(w), 1, 1, True); + XClearArea (dpy, win, widget_x (w), widget_y (w), 1, 1, True); + } + + if (w->sb.timerActive) + { + XtRemoveTimeOut (w->sb.timerId); + w->sb.timerActive = False; } } @@ -1484,13 +1389,9 @@ if (XtIsRealized (widget)) { if (w->sb.fullRedrawNext) - { - redraw_everything (w, NULL, True); - } + redraw_everything (w, NULL, True); else - { - redraw_everything (w, region, False); - } + redraw_everything (w, region, False); w->sb.fullRedrawNext = False; } } @@ -1542,9 +1443,7 @@ } if (cur->sb.orientation != w->sb.orientation) - { - do_redisplay = True; - } + do_redisplay = True; if (cur->sb.minimum != w->sb.minimum || @@ -1558,7 +1457,7 @@ if (XtIsRealized ((Widget) w)) { seg_pixel_sizes (w, &w->sb.above, &w->sb.ss, &w->sb.below); - draw_knob (w, w->sb.above, w->sb.ss, w->sb.below); + draw_slider (w, w->sb.above, w->sb.ss, w->sb.below); } } @@ -1587,7 +1486,6 @@ int increment, int pageIncrement, Boolean notify) { XlwScrollBarWidget w = (XlwScrollBarWidget) widget; - int last_value; if (w && XtClass ((Widget) w) == xlwScrollBarWidgetClass && (w->sb.value != value || @@ -1595,6 +1493,8 @@ w->sb.increment != increment || w->sb.pageIncrement != pageIncrement)) { + int last_value = w->sb.value; + w->sb.value = value; w->sb.sliderSize = sliderSize; w->sb.increment = increment; @@ -1605,55 +1505,43 @@ if (XtIsRealized (widget)) { seg_pixel_sizes (w, &w->sb.above, &w->sb.ss, &w->sb.below); - draw_knob (w, w->sb.above, w->sb.ss, w->sb.below); - - last_value = w->sb.value; - w->sb.value = value_from_pixel (w, w->sb.above); - verify_values (w); + draw_slider (w, w->sb.above, w->sb.ss, w->sb.below); if (w->sb.value != last_value && notify) - { - call_callbacks (w, XmCR_VALUE_CHANGED, w->sb.value, 0, NULL); - } + call_callbacks (w, XmCR_VALUE_CHANGED, w->sb.value, 0, NULL); } } } -/************************************************************************ -** -** Action functions -** -*/ +/*-------------------------- Action Functions ---------------------------*/ static void timer (XtPointer data, XtIntervalId *id) { XlwScrollBarWidget w = (XlwScrollBarWidget) data; - int reason, last_value; - w->sb.timerActive = False; if (w->sb.armed != ARM_NONE) { - last_value = w->sb.value; - reason = XmCR_NONE; + int last_value = w->sb.value; + int reason = XmCR_NONE; switch (w->sb.armed) { case ARM_PAGEUP: - w->sb.value = safe_subtract (w->sb.value, w->sb.pageIncrement); + decrement_value (w, w->sb.pageIncrement); reason = XmCR_PAGE_DECREMENT; break; case ARM_PAGEDOWN: - w->sb.value = safe_add (w->sb.value, w->sb.pageIncrement); + increment_value (w, w->sb.pageIncrement); reason = XmCR_PAGE_INCREMENT; break; case ARM_UP: - w->sb.value = safe_subtract (w->sb.value, w->sb.increment); + decrement_value (w, w->sb.increment); reason = XmCR_DECREMENT; break; case ARM_DOWN: - w->sb.value = safe_add (w->sb.value, w->sb.increment); + increment_value (w, w->sb.increment); reason = XmCR_INCREMENT; break; } @@ -1663,7 +1551,7 @@ if (last_value != w->sb.value) { seg_pixel_sizes (w, &w->sb.above, &w->sb.ss, &w->sb.below); - draw_knob (w, w->sb.above, w->sb.ss, w->sb.below); + draw_slider (w, w->sb.above, w->sb.ss, w->sb.below); call_callbacks (w, reason, w->sb.value, 0, NULL); @@ -1676,180 +1564,97 @@ } } -static int +static button_where what_button (XlwScrollBarWidget w, int mouse_x, int mouse_y) { - int x, y, width, height, arrow_height_top, arrow_height_bottom; - int where; + int width = widget_w (w); + int height = widget_h (w); + int arrow_height = arrow_h (w); - x = widget_x (w); - y = widget_y (w); - width = widget_w (w); - height = widget_h (w); + mouse_x -= widget_x (w); + mouse_y -= widget_y (w); -#if 0 - arrow_height = w->sb.showArrows ? arrow_h (w) : 0; -#endif + if (mouse_x < 0 || mouse_x >= width || + mouse_y < 0 || mouse_y >= height) + return BUTTON_NONE; + if (w->sb.showArrows) { + if (mouse_y >= (height -= arrow_height)) + return BUTTON_DOWN_ARROW; + if (arrow_same_end (w)) { - arrow_height_top = 0; - arrow_height_bottom = 2 * arrow_h (w); + if (mouse_y >= (height -= arrow_height)) + return BUTTON_UP_ARROW; } else - { - arrow_height_top = arrow_height_bottom = arrow_h (w); - } + if ( (mouse_y -= arrow_height) < 0) + return BUTTON_UP_ARROW; } - else - { - arrow_height_top = arrow_height_bottom = 0; - } - - where = BUTTON_NONE; + + if ( (mouse_y -= w->sb.above) < 0) + return BUTTON_TROUGH_ABOVE; - if (mouse_x > x && mouse_x < (x + width)) - { - if (mouse_y > (y + arrow_height_top) && - mouse_y < (y + height - arrow_height_bottom)) - { - if (mouse_y < (y + w->sb.above + arrow_height_top)) - { - where = BUTTON_TROUGH_ABOVE; - } - else if (mouse_y > (y + w->sb.above + w->sb.ss + arrow_height_top)) - { - where = BUTTON_TROUGH_BELOW; - } - else - { - where = BUTTON_KNOB; - } - } - else if (arrow_same_end (w)) - { - if (mouse_y > (y + height - arrow_height_bottom + 1) && - mouse_y < (y + height)) - { - if (mouse_y < (y + height - arrow_height_bottom/2)) - { - where = BUTTON_UP_ARROW; - } - else - { - where = BUTTON_DOWN_ARROW; - } - } - } - else - { - if (mouse_y > y && mouse_y < (y + arrow_height_top)) - { - where = BUTTON_UP_ARROW; - } - else if (mouse_y > (y + height - arrow_height_bottom + 1) && - mouse_y < (y + height)) - { - where = BUTTON_DOWN_ARROW; - } - } - } -#if 0 - if (mouse_x > x && mouse_x < (x + width)) - { - if (mouse_y > (y + arrow_height) && mouse_y < (y + height - arrow_height)) - { - if (mouse_y < (y+w->sb.above+arrow_height)) - { - where = BUTTON_TROUGH_ABOVE; - } - else if (mouse_y > (y + w->sb.above + w->sb.ss + arrow_height)) - { - where = BUTTON_TROUGH_BELOW; - } - else - { - where = BUTTON_KNOB; - } - } - else if (mouse_y > y && mouse_y < (y + arrow_height)) - { - where = BUTTON_UP_ARROW; - } - else if (mouse_y > (y + height - arrow_height + 1) && - mouse_y < (y + height)) - { - where = BUTTON_DOWN_ARROW; - } - } -#endif - return where; + if ( (mouse_y -= w->sb.ss) < 0) + return BUTTON_SLIDER; + + return BUTTON_TROUGH_BELOW; } -#define FORCED_SCROLL_NONE 0 -#define FORCED_SCROLL_DOWNRIGHT 1 -#define FORCED_SCROLL_UPLEFT 2 - -int forced_scroll_flag = FORCED_SCROLL_NONE; - static void PageDownOrRight (Widget widget, XEvent *event, String *parms, Cardinal *num_parms) { - forced_scroll_flag = FORCED_SCROLL_DOWNRIGHT; + XlwScrollBarWidget w = (XlwScrollBarWidget) widget; + w->sb.forced_scroll = FORCED_SCROLL_DOWNRIGHT; Select (widget, event, parms, num_parms); - forced_scroll_flag = FORCED_SCROLL_NONE; + w->sb.forced_scroll = FORCED_SCROLL_NONE; } static void PageUpOrLeft (Widget widget, XEvent *event, String *parms, Cardinal *num_parms) { - forced_scroll_flag = FORCED_SCROLL_UPLEFT; + XlwScrollBarWidget w = (XlwScrollBarWidget) widget; + w->sb.forced_scroll = FORCED_SCROLL_UPLEFT; Select (widget, event, parms, num_parms); - forced_scroll_flag = FORCED_SCROLL_NONE; + w->sb.forced_scroll = FORCED_SCROLL_NONE; } static void Select (Widget widget, XEvent *event, String *parms, Cardinal *num_parms) { XlwScrollBarWidget w = (XlwScrollBarWidget) widget; - int mouse_x, mouse_y; - int reason, last_value; - int sb_button; - - DBUG (fprintf (stderr, "Select:\n")); + button_where sb_button; - mouse_x = event_x (w, event); - mouse_y = event_y (w, event); + int mouse_x = event_x (w, event); + int mouse_y = event_y (w, event); - w->sb.savedValue = w->sb.value; - - last_value = w->sb.value; - reason = XmCR_NONE; + int last_value = w->sb.savedValue = w->sb.value; + int reason = XmCR_NONE; XtGrabKeyboard ((Widget) w, False, GrabModeAsync, GrabModeAsync, event->xbutton.time); sb_button = what_button (w, mouse_x, mouse_y); - if (forced_scroll_flag != FORCED_SCROLL_NONE) + if (w->sb.forced_scroll != FORCED_SCROLL_NONE) { - switch (sb_button) + switch (sb_button) { case BUTTON_TROUGH_ABOVE: case BUTTON_TROUGH_BELOW: - case BUTTON_KNOB: + case BUTTON_SLIDER: sb_button= BUTTON_NONE; /* cause next switch to fall through */ - if (forced_scroll_flag == FORCED_SCROLL_UPLEFT) + if (w->sb.forced_scroll == FORCED_SCROLL_UPLEFT) { - w->sb.value = safe_subtract (w->sb.value, w->sb.pageIncrement); + decrement_value (w, w->sb.pageIncrement); w->sb.armed = ARM_PAGEUP; reason = XmCR_PAGE_DECREMENT; break; } - else if (forced_scroll_flag == FORCED_SCROLL_DOWNRIGHT) + else if (w->sb.forced_scroll == FORCED_SCROLL_DOWNRIGHT) { - w->sb.value = safe_add (w->sb.value, w->sb.pageIncrement); + increment_value (w, w->sb.pageIncrement); w->sb.armed = ARM_PAGEDOWN; reason = XmCR_PAGE_INCREMENT; break; @@ -1861,48 +1666,46 @@ switch (sb_button) { case BUTTON_TROUGH_ABOVE: - w->sb.value = safe_subtract (w->sb.value, w->sb.pageIncrement); + decrement_value (w, w->sb.pageIncrement); w->sb.armed = ARM_PAGEUP; reason = XmCR_PAGE_DECREMENT; break; case BUTTON_TROUGH_BELOW: - w->sb.value = safe_add (w->sb.value, w->sb.pageIncrement); + increment_value (w, w->sb.pageIncrement); w->sb.armed = ARM_PAGEDOWN; reason = XmCR_PAGE_INCREMENT; break; - case BUTTON_KNOB: + case BUTTON_SLIDER: w->sb.lastY = mouse_y; - w->sb.armed = ARM_KNOB; - draw_knob (w, w->sb.above, w->sb.ss, w->sb.below); + w->sb.armed = ARM_SLIDER; + draw_slider (w, w->sb.above, w->sb.ss, w->sb.below); break; case BUTTON_UP_ARROW: if (event->xbutton.state & ControlMask) { - w->sb.value = INT_MIN; - w->sb.armed = ARM_UP; + w->sb.value = w->sb.minimum; reason = XmCR_TO_TOP; } else { - w->sb.value = safe_subtract (w->sb.value, w->sb.increment); - w->sb.armed = ARM_UP; + decrement_value (w, w->sb.increment); reason = XmCR_DECREMENT; } + w->sb.armed = ARM_UP; redraw_up_arrow (w, True, False); break; case BUTTON_DOWN_ARROW: if (event->xbutton.state & ControlMask) { - w->sb.value = INT_MAX; - w->sb.armed = ARM_DOWN; + w->sb.value = w->sb.maximum; reason = XmCR_TO_BOTTOM; } else { - w->sb.value = safe_add (w->sb.value, w->sb.increment); - w->sb.armed = ARM_DOWN; + increment_value (w, w->sb.increment); reason = XmCR_INCREMENT; } + w->sb.armed = ARM_DOWN; redraw_down_arrow (w, True, False); break; } @@ -1912,7 +1715,7 @@ if (last_value != w->sb.value) { seg_pixel_sizes (w, &w->sb.above, &w->sb.ss, &w->sb.below); - draw_knob (w, w->sb.above, w->sb.ss, w->sb.below); + draw_slider (w, w->sb.above, w->sb.ss, w->sb.below); call_callbacks (w, reason, w->sb.value, mouse_y, event); @@ -1933,56 +1736,29 @@ Drag (Widget widget, XEvent *event, String *parms, Cardinal *num_parms) { XlwScrollBarWidget w = (XlwScrollBarWidget) widget; - int diff; - int height, mouse_y; - int last_value, last_above; - DBUG (fprintf (stderr, "Drag:\n")); - - if (w->sb.armed == ARM_KNOB) + if (w->sb.armed == ARM_SLIDER) { - height = widget_h (w); - if (w->sb.showArrows) height -= (2 * arrow_h (w)); - - mouse_y = event_y (w, event); + int mouse_y = event_y (w, event); + int diff = mouse_y - w->sb.lastY; - diff = mouse_y - w->sb.lastY; - - last_above = w->sb.above; - last_value = w->sb.value; - - if (diff < 0) + if (diff < -(w->sb.above)) /* up */ { - /* up */ - w->sb.above -= (-diff); - if (w->sb.above < 0) - { - mouse_y = (mouse_y - w->sb.above); - w->sb.above = 0; - diff = 0; - w->sb.below = height - w->sb.ss; - } - w->sb.below -= diff; - CHECK (w); + mouse_y -= (diff + w->sb.above); + diff = -(w->sb.above); } - else if (diff > 0) + else if (diff > w->sb.below) /* down */ { - /* down */ - w->sb.above += diff; - if (w->sb.above + w->sb.ss > height) - { - mouse_y = height + (mouse_y - (w->sb.above + w->sb.ss)); - w->sb.above = height - w->sb.ss; - diff = 0; - w->sb.below = 0; - } - w->sb.below -= diff; - CHECK (w); + mouse_y -= (diff - w->sb.below); + diff = w->sb.below; } - if (last_above != w->sb.above) + if (diff) { - draw_knob (w, w->sb.above, w->sb.ss, w->sb.below); + w->sb.above += diff; + w->sb.below -= diff; + + draw_slider (w, w->sb.above, w->sb.ss, w->sb.below); w->sb.lastY = mouse_y; @@ -1990,8 +1766,7 @@ verify_values (w); CHECK (w); - if (w->sb.value != last_value) - call_callbacks (w, XmCR_DRAG, w->sb.value, event_y (w, event), event); + call_callbacks (w, XmCR_DRAG, w->sb.value, event_y (w, event), event); } } CHECK (w); @@ -2002,14 +1777,12 @@ { XlwScrollBarWidget w = (XlwScrollBarWidget) widget; - DBUG (fprintf (stderr, "EndDrag:\n")); - switch (w->sb.armed) { - case ARM_KNOB: + case ARM_SLIDER: call_callbacks (w, XmCR_VALUE_CHANGED, w->sb.value, event_y (w, event), event); w->sb.armed = ARM_NONE; - draw_knob (w, w->sb.above, w->sb.ss, w->sb.below); + draw_slider (w, w->sb.above, w->sb.ss, w->sb.below); break; case ARM_UP: redraw_up_arrow (w, False, False); @@ -2028,21 +1801,21 @@ Jump (Widget widget, XEvent *event, String *parms, Cardinal *num_parms) { XlwScrollBarWidget w = (XlwScrollBarWidget) widget; - int x, y, width, height, mouse_x, mouse_y; - int arrow_height; - int last_above, last_value; + int last_value; - DBUG (fprintf (stderr, "Jump:\n")); + int mouse_x = event_x (w, event); + int mouse_y = event_y (w, event); - x = widget_x (w); - y = widget_y (w); - width = widget_w (w); - height = widget_h (w); + int scroll_region_y = widget_y (w); + int scroll_region_h = widget_h (w); - mouse_x = event_x (w, event); - mouse_y = event_y (w, event); - - arrow_height = w->sb.showArrows ? arrow_h (w) : 0; + if (w->sb.showArrows) + { + int arrow_height = arrow_h (w); + scroll_region_h -= 2 * arrow_height; + if (!arrow_same_end (w)) + scroll_region_y += arrow_height; + } XtGrabKeyboard ((Widget) w, False, GrabModeAsync, GrabModeAsync, event->xbutton.time); @@ -2051,45 +1824,31 @@ { case BUTTON_TROUGH_ABOVE: case BUTTON_TROUGH_BELOW: - case BUTTON_KNOB: + case BUTTON_SLIDER: w->sb.savedValue = w->sb.value; - height -= (2*arrow_height); - y += arrow_height; - - last_above = w->sb.above; last_value = w->sb.value; - w->sb.armed = ARM_KNOB; - draw_knob (w, w->sb.above, w->sb.ss, w->sb.below); - - w->sb.above = mouse_y - (w->sb.ss / 2) - arrow_height; + w->sb.above = mouse_y - (w->sb.ss / 2) - scroll_region_y; if (w->sb.above < 0) - { - w->sb.above = 0; - } - else if (w->sb.above + w->sb.ss > height) - { - w->sb.above = height - w->sb.ss; - } - w->sb.below = (height - (w->sb.ss + w->sb.above)); + w->sb.above = 0; + else if (w->sb.above + w->sb.ss > scroll_region_h) + w->sb.above = scroll_region_h - w->sb.ss; + + w->sb.below = scroll_region_h - w->sb.ss - w->sb.above; - if (last_above != w->sb.above) - { - draw_knob (w, w->sb.above, w->sb.ss, w->sb.below); - - w->sb.value = value_from_pixel (w, w->sb.above); - verify_values (w); - CHECK (w); + w->sb.armed = ARM_SLIDER; + draw_slider (w, w->sb.above, w->sb.ss, w->sb.below); - w->sb.lastY = mouse_y; - w->sb.lastY = w->sb.above + arrow_height + (w->sb.ss / 2); + w->sb.value = value_from_pixel (w, w->sb.above); + verify_values (w); + CHECK (w); - if (w->sb.value != last_value) - { - call_callbacks (w, XmCR_DRAG, w->sb.value, event_y (w, event), event); - } - } + w->sb.lastY = mouse_y; + + if (w->sb.value != last_value) + call_callbacks (w, XmCR_DRAG, w->sb.value, mouse_y, event); + break; } CHECK (w); @@ -2100,8 +1859,6 @@ { XlwScrollBarWidget w = (XlwScrollBarWidget) widget; - DBUG (fprintf (stderr, "Abort:\n")); - if (w->sb.armed != ARM_NONE) { if (w->sb.value != w->sb.savedValue) @@ -2109,7 +1866,7 @@ w->sb.value = w->sb.savedValue; seg_pixel_sizes (w, &w->sb.above, &w->sb.ss, &w->sb.below); - draw_knob (w, w->sb.above, w->sb.ss, w->sb.below); + draw_slider (w, w->sb.above, w->sb.ss, w->sb.below); call_callbacks (w, XmCR_VALUE_CHANGED, w->sb.value, event_y (w, event), event); diff -r a0ec055d74dd -r a145efe76779 lwlib/xlwscrollbar.h --- a/lwlib/xlwscrollbar.h Mon Aug 13 09:15:13 2007 +0200 +++ b/lwlib/xlwscrollbar.h Mon Aug 13 09:15:49 2007 +0200 @@ -88,9 +88,14 @@ /* New resources that Motif does not have. Maybe we should use a different prefix. */ + +/* "knob" is obsolete; use "slider" instead. */ #define XmNknobStyle "knobStyle" #define XmCKnobStyle "KnobStyle" +#define XmNsliderStyle "sliderStyle" +#define XmCSliderStyle "SliderStyle" + #define XmNarrowPosition "arrowPosition" #define XmCArrowPosition "ArrowPosition" @@ -114,7 +119,7 @@ XmHORIZONTAL }; -#endif /* _Xm_h */ +#endif /* ! _Xm_h */ extern WidgetClass xlwScrollBarWidgetClass; diff -r a0ec055d74dd -r a145efe76779 lwlib/xlwscrollbarP.h --- a/lwlib/xlwscrollbarP.h Mon Aug 13 09:15:13 2007 +0200 +++ b/lwlib/xlwscrollbarP.h Mon Aug 13 09:15:49 2007 +0200 @@ -27,88 +27,104 @@ /* ** Widget class */ -typedef struct { - int dummy_field; /* keep compiler happy */ +typedef struct +{ + int dummy_field; /* keep compiler happy */ } XlwScrollBarClassPart; -typedef struct _XlwScrollbarClassRec { - CoreClassPart core_class; - XlwScrollBarClassPart scrollbar_class; +typedef struct _XlwScrollbarClassRec +{ + CoreClassPart core_class; + XlwScrollBarClassPart scrollbar_class; } XlwScrollBarClassRec; /* ** Widget instance */ -typedef struct { +typedef struct +{ + /* resources */ + XtCallbackList valueChangedCBL; + XtCallbackList incrementCBL; + XtCallbackList decrementCBL; + XtCallbackList pageIncrementCBL; + XtCallbackList pageDecrementCBL; + XtCallbackList toTopCBL; + XtCallbackList toBottomCBL; + XtCallbackList dragCBL; - /* resources */ - XtCallbackList valueChangedCBL; - XtCallbackList incrementCBL; - XtCallbackList decrementCBL; - XtCallbackList pageIncrementCBL; - XtCallbackList pageDecrementCBL; - XtCallbackList toTopCBL; - XtCallbackList toBottomCBL; - XtCallbackList dragCBL; + Pixel foreground; - Pixel foreground; + Pixel topShadowColor; + Pixel bottomShadowColor; - Pixel topShadowColor; - Pixel bottomShadowColor; + Pixel troughColor; - Pixel troughColor; + Pixel armColor; + Pixel armTopShadowColor; + Pixel armBottomShadowColor; + + Pixmap topShadowPixmap; + Pixmap bottomShadowPixmap; - Pixel armColor; - Pixel armTopShadowColor; - Pixel armBottomShadowColor; + int shadowThickness; + + Boolean showArrows; - Pixmap topShadowPixmap; - Pixmap bottomShadowPixmap; - - int shadowThickness; - - Boolean showArrows; + int minimum; + int maximum; + int sliderSize; + int value; + int pageIncrement; + int increment; - int minimum; - int maximum; - int sliderSize; - int value; - int pageIncrement; - int increment; + int initialDelay; + int repeatDelay; + + unsigned char orientation; + + char *sliderStyle; + char *arrowPosition; - int initialDelay; - int repeatDelay; + /* private */ + Pixmap grayPixmap; - unsigned char orientation; + GC backgroundGC; + GC topShadowGC; + GC bottomShadowGC; - char *knobStyle; - char *arrowPosition; + int above, ss, below; + int lastY; - /* private */ - Pixmap grayPixmap; - - GC backgroundGC; - GC topShadowGC; - GC bottomShadowGC; + enum { + ARM_NONE, + ARM_SLIDER, + ARM_UP, + ARM_DOWN, + ARM_PAGEUP, + ARM_PAGEDOWN + } armed; - int above, ss, below; - int lastY; - - int armed; + enum { + FORCED_SCROLL_NONE, + FORCED_SCROLL_DOWNRIGHT, + FORCED_SCROLL_UPLEFT + } forced_scroll; - int savedValue; + int savedValue; - Boolean fullRedrawNext; + Boolean fullRedrawNext; - Boolean timerActive; - XtIntervalId timerId; + Boolean timerActive; + XtIntervalId timerId; } XlwScrollBarPart; -typedef struct _XlwScrollBarRec { - CorePart core; - XlwScrollBarPart sb; +typedef struct _XlwScrollBarRec +{ + CorePart core; + XlwScrollBarPart sb; } XlwScrollBarRec; -#endif +#endif /* _XlwScrollBarP_h */ diff -r a0ec055d74dd -r a145efe76779 man/ChangeLog --- a/man/ChangeLog Mon Aug 13 09:15:13 2007 +0200 +++ b/man/ChangeLog Mon Aug 13 09:15:49 2007 +0200 @@ -1,3 +1,7 @@ +Tue Feb 25 20:17:53 1997 Steven L Baur + + * auctex/Makefile: Added `mostlyclean' and `distclean' target. + Wed Feb 19 17:57:27 1997 Steven L Baur * Makefile (auctex): New subdirectory target. diff -r a0ec055d74dd -r a145efe76779 man/auctex/Makefile --- a/man/auctex/Makefile Mon Aug 13 09:15:13 2007 +0200 +++ b/man/auctex/Makefile Mon Aug 13 09:15:49 2007 +0200 @@ -74,3 +74,7 @@ allways: + +mostlyclean: clean + +distclean: clean diff -r a0ec055d74dd -r a145efe76779 man/custom.texi --- a/man/custom.texi Mon Aug 13 09:15:13 2007 +0200 +++ b/man/custom.texi Mon Aug 13 09:15:49 2007 +0200 @@ -13,7 +13,7 @@ @comment node-name, next, previous, up @top The Customization Library -Version: 1.44 +Version: 1.46 @menu * Introduction:: @@ -410,6 +410,7 @@ * Declaring Groups:: * Declaring Variables:: * Declaring Faces:: +* Usage for Package Authors:: @end menu All the customization declarations can be changes by keyword arguments. @@ -510,7 +511,7 @@ member. For other types variables, the effect is undefined." @end defun -@node Declaring Faces, , Declaring Variables, Declarations +@node Declaring Faces, Usage for Package Authors, Declaring Variables, Declarations @comment node-name, next, previous, up @subsection Declaring Faces @@ -564,6 +565,22 @@ @end defun +@node Usage for Package Authors, , Declaring Faces, Declarations +@comment node-name, next, previous, up +@subsection Usage for Package Authors + +The recommended usage for the author of a typical emacs lisp package is +to create one group identifying the package, and make all user options +and faces members of that group. If the package has more than around 20 +such options, they should be divided into a number of subgroups, with +each subgroup being member of the top level group. + +The top level group for the package should itself be member of one or +more of the standard customization groups. There exists a group for +each @emph{finder} keyword. Press @kbd{C-c p} to see a list of finder +keywords, and add you group to each of them, using the @code{:group} +keyword. + @node Utilities, The Init File, Declarations, Top @comment node-name, next, previous, up @section Utilities diff -r a0ec055d74dd -r a145efe76779 man/w3.texi --- a/man/w3.texi Mon Aug 13 09:15:13 2007 +0200 +++ b/man/w3.texi Mon Aug 13 09:15:49 2007 +0200 @@ -71,7 +71,9 @@ @end titlepage @page @ifinfo -@node Top, Getting Started,, (DIR) +@node Top, Getting Started, (dir), (dir) +@top W3 + Users can browse the World Wide Web from within Emacs by using Emacs-W3. All of the widely used (and even some not very widely used) @sc{url} schemes are supported, and it is very easy to add new methods as the @@ -83,7 +85,7 @@ with the library. Emacs-W3 is completely customizable, both from Emacs-Lisp and from -stylesheets @xref{Style Sheets} If there is any aspect of Emacs-W3 that +stylesheets @xref{Stylesheets} If there is any aspect of Emacs-W3 that cannot be modified to your satisfaction, please send mail to the @t{w3-beta@@indiana.edu} mailing list with any suggestions. @xref{Reporting Bugs} @@ -93,11 +95,11 @@ * Basic Usage:: Basic movement and usage of Emacs-W3. * Compatibility:: Explanation of compatibility with other browsers. -* Stylesheets:: How to control the look of web pages +* Stylesheets:: How to control the look of web pages * Supported URLs:: What @sc{URL} schemes are supported. * MIME Support:: Support for @sc{mime} * Security:: Various security methods supported -* Non-Unix Operating Systems:: Special considerations necessary to get +* Non-Unix Operating Systems:: Special considerations necessary to get up and running correctly under non-unix OS's. * Speech Integration:: Outputting to a speech synthesizer. @@ -144,6 +146,7 @@ @node Downloading, Building and Installing, Getting Started, Getting Started @section Downloading + :: WORK :: What you need, and why :: WORK :: Where to download Emacs, XEmacs, various platforms :: WORK :: Where to download Emacs-W3 @@ -151,6 +154,7 @@ @node Building and Installing, Startup Files, Downloading, Getting Started @section Building and Installing + :: WORK :: Document makefile variables :: WORK :: Document what gets installed where, why @@ -158,18 +162,20 @@ @section Startup Files @cindex Startup files @cindex Default stylesheet + :: WORK :: startup files This section should document where emacs-w3 looks for its startup files, and what each one does. 'profile' 'stylesheet' 'hotlist' 'history' etc. -@node Preferences Panel, , Startup Files, Getting Started +@node Preferences Panel, , Startup Files, Getting Started @section Preferences Panel @cindex Preferences @kindex M-x w3-preferences-edit + :: WORK :: pref panel This should document the quick preferences panel. M-x w3-preferences-edit -@node Basic Usage, Movement , Getting Started, Top +@node Basic Usage, Compatibility, Getting Started, Top @chapter Basic Usage @cindex Basic Usage @kindex space @@ -205,16 +211,16 @@ There are several areas that the keybindings fall into: movement, information, action, and miscellaneous. -@ifinfo @menu -* Movement:: Moving around in the buffer. -* Information:: Getting information about a document. -* Action:: Following links, printing, etc. -* Miscellaneous:: Everything else. +* Movement:: Moving around in the buffer. +* Information:: Getting information about a document. +* Action:: Following links, printing, etc. +* Miscellaneous:: Everything else. @end menu -@end ifinfo + @node Movement, Information, Basic Usage, Basic Usage @section Movement + All the standard Emacs bindings for movement are still in effect, with a few additions for convenience. @@ -273,6 +279,7 @@ @node Information, Action, Movement, Basic Usage @section Information + These functions relate information about one or more links on the current document. @@ -321,6 +328,7 @@ @node Action, Miscellaneous, Information, Basic Usage @section Action + First, here are the keys and functions that bring up a new hypertext page, usually creating a new buffer. @table @kbd @@ -460,8 +468,9 @@ effect if at the end of the session history. @end table -@node Miscellaneous, Compatibility, Action, Basic Usage +@node Miscellaneous, , Action, Basic Usage @section Miscellaneous + @table @kbd @kindex M-m @findex w3-mail-current-document @@ -563,16 +572,15 @@ relationship. @end table -@node Compatibility, Emulation, Miscellaneous, Top +@node Compatibility, Stylesheets, Basic Usage, Top @chapter Compatibility with other Browsers Due to the popularity of several other browsers, Emacs-W3 offers an easy transition to its much better way of life. This ranges from being able to share the same preferences files and disk cache to actually emulating the keybindings used in other browsers. -@ifinfo @menu -* Emulation:: Emacs-W3 can emulate the keybindings and +* Emulation:: Emacs-W3 can emulate the keybindings and other behaviours of other browsers. * Hotlist Handling:: A hotlist is an easy way to keep track of interesting Web pages without having to @@ -580,10 +588,10 @@ * Session History:: Keeping a history of documents visited in one Emacs sessions allows the use of 'forward' and 'back' buttons easily. -* Global History:: Keeping a history of all the places ever +* Global History:: Keeping a history of all the places ever visited on the web. @end menu -@end ifinfo + @node Emulation, Hotlist Handling, Compatibility, Compatibility @section Emulation @cindex Browser emulation @@ -595,6 +603,7 @@ @findex w3-netscape-emulation-minor-mode @findex w3-lynx-emulation-minor-mode @vindex w3-mode-hook + :: WORK :: Document lynx emulation @table @bullet @item Down arrow @@ -724,6 +733,7 @@ @node Hotlist Handling, Session History, Emulation, Compatibility @section Hotlist Handling + :: WORK :: Document that it supports different types of hotlist formats :: WORK :: Make sure everything hotlist related can be accessed via 'h' In order to avoid having to traverse many documents to get to the same @@ -792,12 +802,15 @@ @node Session History, Global History, Hotlist Handling, Compatibility @section History @cindex History Lists + Almost all web browsers keep track of the @sc{url}s followed from a page, so that it can provide @b{forward} and @b{back} buttons to keep a @i{path} of @sc{url}s that can be traversed easily. + @vindex url-keep-history If the variable @code{url-keep-history} is @code{t}, then Emacs-W3 keeps a list of all the @sc{url}s visited in a session. + @findex w3-show-history To view a listing of the history for this session of Emacs-W3, use @code{M-x w3-show-history} from any buffer, and Emacs-W3 generates an @@ -817,8 +830,9 @@ document. To go forward, use the function @code{w3-forward-in-history}, to go backward, use the function @code{w3-backward-in-history}. -@node Global History, Stylesheets, Session History, Compatibility +@node Global History, , Session History, Compatibility @section Global History + :: WORK :: Document that the global history can have diff. formats Most web browsers also support the idea of a ``history'' of @sc{url}s the user has visited, and it displays them in a different style than normal @@ -848,7 +862,7 @@ are not in a hotlist, or for seeing all the pages from a particular web site before choosing which to retrieve. -@node Stylesheets, Terminology, Global History, Top +@node Stylesheets, Supported URLs, Compatibility, Top @chapter Stylesheets The way in which Emacs-W3 formats a document is very customizable. All formatting is now controlled by a default stylesheet set by the user @@ -868,7 +882,6 @@ in the following sections comes directly from the specification as well. -@ifinfo @menu * Terminology:: Terms used in the rest of this chapter. * Basic Concepts:: Why are stylesheets useful? Getting started. @@ -877,7 +890,6 @@ * Properties:: What properties you can set on elements. * Units:: What you can set them to. @end menu -@end ifinfo @node Terminology, Basic Concepts, Stylesheets, Stylesheets @section Terminology @@ -978,6 +990,7 @@ @node Basic Concepts, Pseudo-Classes/Elements, Terminology, Stylesheets @section Basic Concepts + Designing simple style sheets is easy. One needs only to know a little HTML and some basic desktop publishing terminology. E.g., to set the text color of 'H1' elements to blue, one can say: @@ -1000,6 +1013,7 @@ @node Pseudo-Classes/Elements, The Cascade, Basic Concepts, Stylesheets @section Pseudo-Classes/Elements + In @sc{css1}, style is normally attached to an element based on its position in the document structure. This simple model is sufficient for a wide variety of styles, but doesn't cover some common effects. The @@ -1208,7 +1222,7 @@ policy will make it easier for stylistic attributes to coexist with style sheets. -@node Properties, Font Properties, The Cascade, Stylesheets +@node Properties, Units, The Cascade, Stylesheets @section Properties In the text below, the allowed values for each property are listed @@ -1269,7 +1283,6 @@ @item Percentage values: @tab What a percentage value applies to when given. @end multitable -@ifinfo @menu * Font Properties:: Selecting fonts, styles, and sizes. * Colors and Backgrounds:: Controlling colors, front and back. @@ -1279,10 +1292,10 @@ * Media Selection:: Conditionalize stylesheets on media-type. * Speech Properties:: Speech output controlled by stylesheets. @end menu -@end ifinfo - -@node Font Properties, font-family, Properties, Properties + +@node Font Properties, Colors and Backgrounds, Properties, Properties @subsection Font Properties + Setting font properties will be among the most common uses of style sheets. Unfortunately, there exists no well-defined and universally accepted taxonomy for classifying fonts, and terms that apply to one @@ -1293,7 +1306,6 @@ selection properties to a specific font. The properties defined by CSS1 are described in the following sections. -@ifinfo @menu * font-family:: Groups of fonts. * font-style:: Normal, italic, or oblique? @@ -1302,7 +1314,6 @@ * font-size:: How big is yours? * font:: Shorthand for all of the above. @end menu -@end ifinfo @node font-family, font-style, Font Properties, Font Properties @subsubsection font-family @@ -1543,7 +1554,7 @@ If the suggested scaling factor of 1.5 is used, the last three declarations are identical. -@node font, Colors and Backgrounds, font-size, Font Properties +@node font, , font-size, Font Properties @subsubsection font @multitable @columnfractions .2 .8 @@ -1587,8 +1598,9 @@ 'normal' applies to the two remaining properties: 'font-style' and 'font-weight'. -@node Colors and Backgrounds, color, font, Properties +@node Colors and Backgrounds, Text Properties, Font Properties, Properties @subsection Colors and Backgrounds + These properties describe the color (often called foreground color) and background of an element (i.e. the surface onto which the content is rendered). One can set a background color and/or a background image. The @@ -1603,20 +1615,19 @@ NOTE: Currently, Emacs-W3 can only show background images under XEmacs. Emacs 19 doesn't have the support in its display code yet. -@ifinfo @menu -* color:: Foreground colors. -* background-color:: Background colors. -* background-image:: Background images. -* background-repeat:: Controlling repeating of background images. -* background-attachment:: Where background images are drawn. -* background-position:: Where background images are drawn. -* background:: Shorthand for all background properties. +* color:: Foreground colors. +* background-color:: Background colors. +* background-image:: Background images. +* background-repeat:: Controlling repeating of background images. +* background-attachment:: Where background images are drawn. +* background-position:: Where background images are drawn. +* background:: Shorthand for all background properties. @end menu -@end ifinfo @node color, background-color, Colors and Backgrounds, Colors and Backgrounds @subsubsection color + @multitable @columnfractions .2 .8 @item Value: @tab @item Initial: @tab User specific @@ -1637,6 +1648,7 @@ @node background-color, background-image, color, Colors and Backgrounds @subsubsection background-color + @multitable @columnfractions .2 .8 @item Value: @tab | transparent @item Initial: @tab transparent @@ -1653,6 +1665,7 @@ @node background-image, background-repeat, background-color, Colors and Backgrounds @subsubsection background-image + @multitable @columnfractions .2 .8 @item Value: @tab | none @item Initial: @tab none @@ -1673,18 +1686,22 @@ @node background-repeat, background-attachment, background-image, Colors and Backgrounds @subsubsection background-repeat + This property is not supported at all under Emacs-W3. @node background-attachment, background-position, background-repeat, Colors and Backgrounds @subsubsection background-attachment + This property is not supported at all under Emacs-W3. @node background-position, background, background-attachment, Colors and Backgrounds @subsubsection background-position + This property is not supported at all under Emacs-W3. -@node background, Text Properties, background-position, Colors and Backgrounds +@node background, , background-position, Colors and Backgrounds @subsubsection background + @multitable @columnfractions .2 .8 @item Value: @tab || || || || @item Initial: @tab not defined for shorthand properties @@ -1712,10 +1729,9 @@ are set to their initial value. In the second rule, all individual properties have been specified. -@node Text Properties, word-spacing, background, Properties +@node Text Properties, Box Properties, Colors and Backgrounds, Properties @subsection Text Properties -@ifinfo @menu * word-spacing:: * letter-spacing:: @@ -1726,10 +1742,10 @@ * text-indent:: * line-height:: @end menu -@end ifinfo @node word-spacing, letter-spacing, Text Properties, Text Properties @subsubsection word-spacing + @multitable @columnfractions .2 .8 @item Supported Values: @tab normal @item Unsupported Values: @tab @@ -1757,8 +1773,9 @@ @node letter-spacing, text-decoration, word-spacing, Text Properties @subsubsection letter-spacing + @multitable @columnfractions .2 .8 -@item Supported Values: normal +@item Supported Values: @tab normal @item Unsupported Values: @tab @item Initial: @tab normal @item Applies to: @tab all elements @@ -1782,8 +1799,9 @@ NOTE: Emacs-W3 cannot currently support this, due to limitations in Emacs. It may be implemented in the future. -@node text-decoration, vertical-align, letter-spacing , Text Properties +@node text-decoration, vertical-align, letter-spacing, Text Properties @subsubsection text-decoration + @multitable @columnfractions .2 .8 @item Supported Values: @tab none | underline | line-through | blink @item Unsupported Values: @tab overline @@ -1820,10 +1838,12 @@ @node vertical-align, text-transform, text-decoration, Text Properties @subsubsection vertical-align + This is currently unsupported in Emacs-W3. @node text-transform, text-align, vertical-align, Text Properties @subsubsection text-transform + @multitable @columnfractions .2 .8 @item Supported Values: @tab none @item Unsupported Values: @tab capitalize | uppercase | lowercase @@ -1858,6 +1878,7 @@ @node text-align, text-indent, text-transform, Text Properties @subsubsection text-align + @multitable @columnfractions .2 .8 @item Value: @tab left | right | center | justify @item Initial: @tab User specific @@ -1880,19 +1901,23 @@ @node text-indent, line-height, text-align, Text Properties @subsubsection text-indent + Not currently implemented in Emacs-W3. -@node line-height, Box Properties, text-indent, Text Properties +@node line-height, , text-indent, Text Properties @subsubsection line-height + Not currently implemented in Emacs-W3. -@node Box Properties, Classification, line-height, Properties +@node Box Properties, Classification, Text Properties, Properties @subsection Box Properties + @multitable @columnfractions .2 .8 @end multitable -@node Classification, display, Box Properties, Properties +@node Classification, Media Selection, Box Properties, Properties @subsection Classification + These properties classify elements into categories more than they set specific visual parameters. @@ -1903,19 +1928,18 @@ 'display' value of 'list-item'. In HTML this is typically the case for the 'LI' element. -@ifinfo @menu -* display:: -* white-space:: -* list-style-type:: -* list-style-image:: -* list-style-position:: -* list-style:: +* display:: +* white-space:: +* list-style-type:: +* list-style-image:: +* list-style-position:: +* list-style:: @end menu -@end ifinfo @node display, white-space, Classification, Classification @subsubsection display + @multitable @columnfractions .2 .8 @item Value: @tab block | inline | list-item | none @item Extensions: @tab line @@ -1957,6 +1981,7 @@ @node white-space, list-style-type, display, Classification @subsubsection white-space + @multitable @columnfractions .2 .8 @item Value: @tab normal | pre | nowrap @item Initial: @tab normal @@ -1977,6 +2002,7 @@ @node list-style-type, list-style-image, white-space, Classification @subsubsection list-style-type + @multitable @columnfractions .2 .8 @item Value: @tab disc | circle | square | decimal | lower-roman | upper-roman | lower-alpha | upper-alpha | none @item Initial: @tab disc @@ -1998,6 +2024,7 @@ @node list-style-image, list-style-position, list-style-type, Classification @subsubsection list-style-image + @multitable @columnfractions .2 .8 @item Value: @tab | none @item Initial: @tab none @@ -2018,6 +2045,7 @@ @node list-style-position, list-style, list-style-image, Classification @subsubsection list-style-position + @multitable @columnfractions .2 .8 @item Supported Values: @tab outside @item Unsupported Values: @tab inside @@ -2031,10 +2059,11 @@ is drawn with regard to the content. For a formatting example see section 4.1.3. -@node list-style, Media Selection, list-style-position, Classification +@node list-style, , list-style-position, Classification @subsubsection list-style + @multitable @columnfractions .2 .8 -@item Value: || || +@item Value: @tab || || @item Initial: @tab not defined for shorthand properties @item Applies to: @tab elements with 'display' value 'list-item' @item Inherited: @tab yes @@ -2092,8 +2121,9 @@ In the example above, the 'disc' will be used when the image is unavailable. -@node Media Selection, Speech Properties, list-style, Properties +@node Media Selection, Speech Properties, Classification, Properties @subsection Media Selection + To specify that a stylesheet declaration should only apply when using a certain media type (ie: different font families preferred when printing versus on-screen presentation), the declarations should be wrapped in @@ -2141,8 +2171,9 @@ The default value, the style sheet applies to all output devices @end table -@node Speech Properties, volume, Media Selection, Properties +@node Speech Properties, , Media Selection, Properties @subsection Speech Properties + Those of us who are sighted are accustomed to visual presentation of @sc{html} documents, frequently on a bitmapped display. This is not the only possible presentation method, however. Aural presentation, using a @@ -2170,31 +2201,30 @@ produce truly multimodal documents. @end itemize -@ifinfo @menu -* volume:: -* pause-before:: -* pause-after:: -* pause:: -* cue-before:: -* cue-after:: -* cue:: -* play-during:: -* speed:: -* voice-family:: -* pitch:: -* pitch-range:: -* stress:: -* richness:: -* speak-punctuation:: -* speak-date:: -* speak-numeral:: -* speak-time:: +* volume:: +* pause-before:: +* pause-after:: +* pause:: +* cue-before:: +* cue-after:: +* cue:: +* play-during:: +* speed:: +* voice-family:: +* pitch:: +* pitch-range:: +* stress:: +* richness:: +* speak-punctuation:: +* speak-date:: +* speak-numeral:: +* speak-time:: @end menu -@end ifinfo @node volume, pause-before, Speech Properties, Speech Properties @subsubsection volume + @multitable @columnfractions .2 .8 @item Value: @tab | mute | x-soft | soft | medium | loud | x-loud @item Initial: @tab medium @@ -2251,6 +2281,7 @@ @node pause-before, pause-after, volume, Speech Properties @subsubsection pause-before + @multitable @columnfractions .2 .8 @item Value: @tab