## General Public License for more details.
## You should have received a copy of the GNU General Public License
-## along with this program. If not, see <http://www.gnu.org/licenses/>.
+## along with this program. If not, see <http://www.gnu.org/licenses/>.
## Process this file with automake to produce Makefile.in
TAGS_DEPENDENCIES = $(ETAGS)
ETAGS_ARGS =
-sxepkg_DATA =
-xepkg_DATA =
-mulepkg_DATA =
-sitepkg_DATA =
+sxepkg_DATA =
+xepkg_DATA =
+mulepkg_DATA =
+sitepkg_DATA =
subdirs = ffi mule term
cus-edit.el cus-face.el cus-file.el cus-load.el cus-start.el \
custom.el derived.el device.el dialog-items.el dialog.el \
disass.el disp-table.el dragdrop.el easy-mmode.el easymenu.el \
- emod-utils.el etags.el events.el extents.el faces.el ffi.el \
- files-nomule.el files.el fill.el float-sup.el font-lock.el \
+ emod-utils.el etags.el events.el extents.el faces.el ffi.el \
+ files-nomule.el files.el fill.el float-sup.el font-lock.el \
font-menu.el font.el fontl-hooks.el format.el frame.el \
glyphs.el gnuserv.el gpm.el gui.el gutter-items.el gutter.el \
help-macro.el help-nomule.el help.el hyper-apropos.el indent.el \
mule/cyrillic.el mule/english.el mule/ethiopic.el \
mule/european.el mule/greek.el mule/hebrew.el mule/japanese.el \
mule/kinsoku.el mule/korean.el mule/latin.el mule/misc-lang.el \
- mule/mule-category.el mule/ccl.el mule/mule-charset.el \
+ mule/mule-category.el mule/ccl.el mule/mule-charset.el \
mule/mule-cmds.el mule/mule-coding.el mule/mule-help.el \
mule/mule-init.el mule/mule-misc.el mule/mule-tty-init.el \
mule/mule-x-init.el mule/thai-xtis-chars.el mule/thai-xtis.el \
builtels = \
auto-autoloads.el custom-load.el finder-inf.el \
- custom-defines.el
+ custom-defines.el
ffibuiltels = \
- ffi/auto-autoloads.el ffi/custom-load.el \
- ffi/custom-defines.el
+ ffi/auto-autoloads.el ffi/custom-load.el \
+ ffi/custom-defines.el
mulebuiltels = \
- mule/auto-autoloads.el mule/custom-load.el \
- mule/custom-defines.el
+ mule/auto-autoloads.el mule/custom-load.el \
+ mule/custom-defines.el
if HAVE_FFI
builtels += $(mulebuiltels)
endif
-nocompile_elfiles =
+nocompile_elfiles =
compile_elfiles = $(compile_bldchainels) $(corelispels) $(termlispels)
if HAVE_FFI
compile_elfiles += $(ffilispels)
;; General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Synched up with: FSF 19.34 (With some additions)
of the form (ABBREVNAME EXPANSION HOOK USECOUNT)."
(let ((table (and (boundp table-name) (symbol-value table-name))))
(cond ((vectorp table))
- ((not table)
- (setq table (make-abbrev-table))
- (set table-name table)
- (setq abbrev-table-name-list (cons table-name abbrev-table-name-list)))
- (t
- (setq table (wrong-type-argument 'vectorp table))
- (set table-name table)))
+ ((not table)
+ (setq table (make-abbrev-table))
+ (set table-name table)
+ (setq abbrev-table-name-list (cons table-name abbrev-table-name-list)))
+ (t
+ (setq table (wrong-type-argument 'vectorp table))
+ (set table-name table)))
(while definitions
(apply (function define-abbrev) table (car definitions))
(setq definitions (cdr definitions)))))
(check-type count (or null integer))
(check-type table vector)
(let* ((sym (intern name table))
- (oexp (and (boundp sym) (symbol-value sym)))
- (ohook (and (fboundp sym) (symbol-function sym))))
+ (oexp (and (boundp sym) (symbol-value sym)))
+ (ohook (and (fboundp sym) (symbol-function sym))))
(unless (and (equal ohook hook)
(stringp oexp)
(stringp expansion)
(while l
(let ((fixup (car l)))
(if (consp fixup)
- (progn
- (setq abbrev-table-name-list (delq fixup abbrev-table-name-list))
- (define-abbrev-table (car fixup) (cdr fixup))))
+ (progn
+ (setq abbrev-table-name-list (delq fixup abbrev-table-name-list))
+ (define-abbrev-table (car fixup) (cdr fixup))))
(setq l (cdr l))))
;; These are no longer initialized by C code
(if (not global-abbrev-table)
(progn
- (setq global-abbrev-table (make-abbrev-table))
- (setq abbrev-table-name-list (cons 'global-abbrev-table
- abbrev-table-name-list))))
+ (setq global-abbrev-table (make-abbrev-table))
+ (setq abbrev-table-name-list (cons 'global-abbrev-table
+ abbrev-table-name-list))))
(if (not fundamental-mode-abbrev-table)
(progn
- (setq fundamental-mode-abbrev-table (make-abbrev-table))
- (setq abbrev-table-name-list (cons 'fundamental-mode-abbrev-table
- abbrev-table-name-list))))
+ (setq fundamental-mode-abbrev-table (make-abbrev-table))
+ (setq abbrev-table-name-list (cons 'fundamental-mode-abbrev-table
+ abbrev-table-name-list))))
(and (eq major-mode 'fundamental-mode)
(not local-abbrev-table)
(setq local-abbrev-table fundamental-mode-abbrev-table)))
"Define ABBREV as a global abbreviation for EXPANSION."
(interactive "sDefine global abbrev: \nsExpansion for %s: ")
(define-abbrev global-abbrev-table
- (downcase name) expansion nil 0))
+ (downcase name) expansion nil 0))
(defun define-mode-abbrev (name expansion)
"Define ABBREV as a mode-specific abbreviation for EXPANSION."
(interactive "sDefine mode abbrev: \nsExpansion for %s: ")
(define-abbrev (or local-abbrev-table
- (error "Major mode has no abbrev table"))
+ (error "Major mode has no abbrev table"))
(downcase name) expansion nil 0))
(defun abbrev-symbol (abbrev &optional table)
Optional second arg TABLE is abbrev table to look it up in.
The default is to try buffer's mode-specific abbrev table, then global table."
(let ((frob (function (lambda (table)
- (let ((sym (intern-soft abbrev table)))
- (if (and (boundp sym)
- (stringp (symbol-value sym)))
- sym
- nil))))))
+ (let ((sym (intern-soft abbrev table)))
+ (if (and (boundp sym)
+ (stringp (symbol-value sym)))
+ sym
+ nil))))))
(if table
- (funcall frob table)
- (or (and local-abbrev-table
- (funcall frob local-abbrev-table))
- (funcall frob global-abbrev-table)))))
+ (funcall frob table)
+ (or (and local-abbrev-table
+ (funcall frob local-abbrev-table))
+ (funcall frob global-abbrev-table)))))
(defun abbrev-expansion (abbrev &optional table)
"Return the string that ABBREV expands into in the current buffer.
then ABBREV is looked up in that table only."
(let ((sym (abbrev-symbol abbrev table)))
(if sym
- (symbol-value sym)
- nil)))
+ (symbol-value sym)
+ nil)))
(defun unexpand-abbrev ()
"Undo the expansion of the last abbrev that expanded.
is not undone."
(interactive)
(if (or (< last-abbrev-location (point-min))
- (> last-abbrev-location (point-max))
- (not (stringp last-abbrev-text)))
+ (> last-abbrev-location (point-max))
+ (not (stringp last-abbrev-text)))
nil
(let* ((opoint (point))
- (val (symbol-value last-abbrev))
- (adjust (length val)))
+ (val (symbol-value last-abbrev))
+ (adjust (length val)))
;; This isn't correct if (symbol-function last-abbrev-text)
;; was used to do the expansion
(goto-char last-abbrev-location)
(setq adjust (- adjust (length last-abbrev-text)))
(setq last-abbrev-text nil)
(if (< last-abbrev-location opoint)
- (goto-char (- opoint adjust))
- (goto-char opoint)))))
+ (goto-char (- opoint adjust))
+ (goto-char opoint)))))
\f
expression, a call to `define-abbrev-table', which would define the
abbrev table NAME exactly as it is currently defined."
(let ((table (symbol-value name))
- (stream (current-buffer)))
+ (stream (current-buffer)))
(message "Abbrev-table %s..." name)
(if human-readable
- (progn
- (prin1 (list name) stream)
- ;; Need two terpri's or cretinous edit-abbrevs blows out
- (terpri stream)
- (terpri stream)
- (mapatoms (function (lambda (sym)
- (if (symbol-value sym)
- (let* ((n (prin1-to-string (symbol-name sym)))
- (pos (length n)))
- (princ n stream)
- (while (< pos 14)
- (write-char ?\ stream)
- (setq pos (1+ pos)))
- (princ (format " %-5S " (symbol-plist sym))
- stream)
- (if (not (symbol-function sym))
- (prin1 (symbol-value sym) stream)
- (progn
- (setq n (prin1-to-string (symbol-value sym))
- pos (+ pos 6 (length n)))
- (princ n stream)
- (while (< pos 45)
- (write-char ?\ stream)
- (setq pos (1+ pos)))
- (prin1 (symbol-function sym) stream)))
- (terpri stream)))))
- table)
- (terpri stream))
- (progn
- (princ "\(define-abbrev-table '" stream)
- (prin1 name stream)
- (princ " '\(\n" stream)
- (mapatoms (function (lambda (sym)
- (if (symbol-value sym)
- (progn
- (princ " " stream)
- (prin1 (list (symbol-name sym)
- (symbol-value sym)
- (symbol-function sym)
- (symbol-plist sym))
- stream)
- (terpri stream)))))
- table)
- (princ " \)\)\n" stream)))
+ (progn
+ (prin1 (list name) stream)
+ ;; Need two terpri's or cretinous edit-abbrevs blows out
+ (terpri stream)
+ (terpri stream)
+ (mapatoms (function (lambda (sym)
+ (if (symbol-value sym)
+ (let* ((n (prin1-to-string (symbol-name sym)))
+ (pos (length n)))
+ (princ n stream)
+ (while (< pos 14)
+ (write-char ?\ stream)
+ (setq pos (1+ pos)))
+ (princ (format " %-5S " (symbol-plist sym))
+ stream)
+ (if (not (symbol-function sym))
+ (prin1 (symbol-value sym) stream)
+ (progn
+ (setq n (prin1-to-string (symbol-value sym))
+ pos (+ pos 6 (length n)))
+ (princ n stream)
+ (while (< pos 45)
+ (write-char ?\ stream)
+ (setq pos (1+ pos)))
+ (prin1 (symbol-function sym) stream)))
+ (terpri stream)))))
+ table)
+ (terpri stream))
+ (progn
+ (princ "\(define-abbrev-table '" stream)
+ (prin1 name stream)
+ (princ " '\(\n" stream)
+ (mapatoms (function (lambda (sym)
+ (if (symbol-value sym)
+ (progn
+ (princ " " stream)
+ (prin1 (list (symbol-name sym)
+ (symbol-value sym)
+ (symbol-function sym)
+ (symbol-plist sym))
+ stream)
+ (terpri stream)))))
+ table)
+ (princ " \)\)\n" stream)))
(terpri stream))
(message ""))
;;; End code not in FSF
(defvar about-other-current-hackers '(peanuthorst))
(defvar about-once-and-future-hackers
- '(adrian aj ajc alastair baw ben bw cgw chr craig cthomp daiki dan darrylo
- devin dkindred dmoore dv eb fabrice golubev gunnar heatxsink hbs hisashi
- hmuller hniksic hobley jan jareth jason jens jmiller jonathan juhp
+ '(adrian aj ajc alastair baw ben bw cgw chr craig cthomp daiki dan darrylo
+ devin dkindred dmoore dv eb fabrice golubev gunnar heatxsink hbs hisashi
+ hmuller hniksic hobley jan jareth jason jens jmiller jonathan juhp
jwz kazz kirill kyle larsi marcpa martin mcook mly morioka mta myrkraverk
ograf olivier oscar pelegri pez piper pittman rendhalver rickc rose
rossini slb sperber stig stigb thiessel tomonori tuck turnbull vin
(normal-range (- msglen width))
(long-border-interval 1.5)
(long-default-interval 0.15)
- submsg)
+ submsg)
(if (< msglen width)
- (display-message 'no-log (concat leader msg))
+ (display-message 'no-log (concat leader msg))
(while t
- (dotimes (i msglen)
- (setq submsg (if (< i normal-range)
- (substring msg i (+ i width))
- ;; Rolling is needed.
- (concat (substring msg i)
- (substring msg 0 (- (+ i width) msglen)))))
- (display-message 'no-log (concat leader submsg))
- (unless (sit-for (cond
- ((eq i 0) long-border-interval)
- (t long-default-interval)))
- (return-from about-rolling-message)))
- (garbage-collect)))))
+ (dotimes (i msglen)
+ (setq submsg (if (< i normal-range)
+ (substring msg i (+ i width))
+ ;; Rolling is needed.
+ (concat (substring msg i)
+ (substring msg 0 (- (+ i width) msglen)))))
+ (display-message 'no-log (concat leader submsg))
+ (unless (sit-for (cond
+ ((eq i 0) long-border-interval)
+ (t long-default-interval)))
+ (return-from about-rolling-message)))
+ (garbage-collect)))))
;; Main entry page.
to think of that killer product...
See also ")
- (about-url-link 'alastair nil "Visit Alastair's home page")
- (widget-insert ".\n"))
+ (about-url-link 'alastair nil "Visit Alastair's home page")
+ (widget-insert ".\n"))
(baw
(widget-insert "
As of November 2000, I am a software engineer with the Pythonlabs at
Milk Me Daddy
(C) 1990 Warsaw
===============
- Oh daddy with your fingers pink
- From whose udders do you drink?
- Thy milk offends with putrid stink
- I'll vomit now, lactose I think
-
- If I could dream, I'd be a cow
- Not horse, or mule, or barnyard sow
- The cud I'd chew would drip and how!
- So milk me daddy, milk me now!
-
- My bovine nature knows no bounds
- I'd naught awake at midnight sounds
- Of teens approaching o'er the grounds
- To tip with glee, then screech like clowns
-
- And so I stare into this glass
- Of sweaty juice, I gulp so fast
- Each drop I lick, down to the last
- The vertigo I know will pass
-
- My mother smiles and pats my head
- She's proud of me, so she has said
- My pop just now gets out of bed
- His eyes quite comatose and red
-
- He'll empathize my milky fate
- Whilest sopping gravy from his plate
- And as the hour is getting late
- His belly taut with all he ate
-
- He isn't often quite so chatty
- His arteries clogged with meat so fatty
- With burps that launch soup, thick and splatty
+ Oh daddy with your fingers pink
+ From whose udders do you drink?
+ Thy milk offends with putrid stink
+ I'll vomit now, lactose I think
+
+ If I could dream, I'd be a cow
+ Not horse, or mule, or barnyard sow
+ The cud I'd chew would drip and how!
+ So milk me daddy, milk me now!
+
+ My bovine nature knows no bounds
+ I'd naught awake at midnight sounds
+ Of teens approaching o'er the grounds
+ To tip with glee, then screech like clowns
+
+ And so I stare into this glass
+ Of sweaty juice, I gulp so fast
+ Each drop I lick, down to the last
+ The vertigo I know will pass
+
+ My mother smiles and pats my head
+ She's proud of me, so she has said
+ My pop just now gets out of bed
+ His eyes quite comatose and red
+
+ He'll empathize my milky fate
+ Whilest sopping gravy from his plate
+ And as the hour is getting late
+ His belly taut with all he ate
+
+ He isn't often quite so chatty
+ His arteries clogged with meat so fatty
+ With burps that launch soup, thick and splatty
Oh how I wish you'd milk me daddy\n\n\t")
(about-url-link 'baw nil "Visit Barry's home page")
(widget-insert "\n"))
In real life most of the time my name is Sebastian Freundt.
I'm a mathematician at the ")
(about-url-link "http://www.math.tu-berlin.de"
- "Technical University of Berlin"
- "www.math.tu-berlin.de")
+ "Technical University of Berlin"
+ "www.math.tu-berlin.de")
(widget-insert ".
My main task there is to hack at the computer algebra system KANT/KASH,
and incorporate the ideas of the SCIEnce project.
xxML and hairy script languages !) and the Scheme language.\n"))
(peanuthorst
(widget-insert "
-Horst is a student still working towards his HSC. He has a Unit II
-certification in Information Technology already, and is studying
+Horst is a student still working towards his HSC. He has a Unit II
+certification in Information Technology already, and is studying
Chemistry, German, and Physics.
He started using XEmacs relatively recently, when he started with Linux
spent some time in DevPro (that is when I made my contribution to
XEmacs) and joined JavaSoft in fall '95, where I've been the lead for
several JSP-related specifications and JAX-RPC. I'm currently the Web
-Layer architect for J2EE.
+Layer architect for J2EE.
I was born in Barcelona and I grew up mostly in Caracas; I have two kids
and I speak only catalan to them; I can juggle some (career, family, and
circuits with special emphasis on distributed software concepts. He
has now joined HP as technical consultant.
- All of the buildings,
- all of the cars
- were once just a dream
- in somebody's head.\n
- P. Gabriel\n"))
+ All of the buildings,
+ all of the cars
+ were once just a dream
+ in somebody's head.\n
+ P. Gabriel\n"))
(tomonori
(widget-insert
"
(dkindred
(widget-insert "
Darrell tends to come out of the woodwork a couple of weeks
-before a new release with a flurry of fixes for bugs that
+before a new release with a flurry of fixes for bugs that
annoy him. He hopes he's spared you from a core dump or two.\n"))
(dmoore
(widget-insert "
(gunnar
(widget-insert
"
-Sorry, no information about my XEmacs contributions yet.\n"))
+Sorry, no information about my XEmacs contributions yet.\n"))
(hbs
(widget-insert "
Part of the original (pre-19.0) Lucid Emacs development team. Harlan
tables.\n"))
(heatxsink
(widget-insert "
-Sorry, no information about my SXEmacs contributions yet.\n"))
+Sorry, no information about my SXEmacs contributions yet.\n"))
(hisashi
(widget-insert
"
;; Reading DOC file doesn't load nroff.
;; Added hypertext following of documentation, mouse-2 on variable gives value
;; from buffer in active window.
-;; Added apropos-rewrite-regexp from FSF apropos.
+;; Added apropos-rewrite-regexp from FSF apropos.
;;; Code:
;; I see a degradation of maybe 10-20% only.
at the function and at the names and values of properties.
Returns list of symbols and values found."
(interactive "sApropos value (regexp): \nP")
- (setq apropos-regexp (apropos-rewrite-regexp apropos-regexp))
+ (setq apropos-regexp (apropos-rewrite-regexp apropos-regexp))
(or do-all (setq do-all apropos-do-all))
(setq apropos-accumulator ())
(let (f v p)
Includes everything that can get us into trouble Unix.")
;; This code based on code in Bill Perry's url.el.
-
+
(defun auto-save-escape-name (str)
"Escape any evil nasty characters in a potential filename.
Uses quoted-printable-style escaping -- e.g. the dreaded =3D.
(make-variable-buffer-local 'auto-show-mode)
-(defcustom auto-show-shift-amount 8
+(defcustom auto-show-shift-amount 8
"*Extra columns to scroll. for automatic horizontal scrolling."
:type 'integer
:group 'auto-show)
is next called (this happens after every command)."
(if (auto-show-should-take-action-p)
(let* ((scroll (window-hscroll)) ;how far window is scrolled
- (w-width (- (window-width)
+ (w-width (- (window-width)
(if (> scroll 0)
2 1))) ;how wide window is on the screen
(right-col (+ scroll w-width))
(if (auto-show-should-take-action-p)
(let* ((col (current-column)) ;column on line point is at
(scroll (window-hscroll)) ;how far window is scrolled
- (w-width (- (window-width)
+ (w-width (- (window-width)
(if (> scroll 0)
2 1))) ;how wide window is on the screen
(right-col (+ scroll w-width)))
(if (or (> col right-col) ;to the right of the screen
(and (= col right-col)
(not (eolp))))
- (scroll-left (+ auto-show-shift-amount
+ (scroll-left (+ auto-show-shift-amount
(- col (+ scroll w-width))))))))))
;; XEmacs change:
easy-mmode-define-minor-mode easy-mmode-define-global-mode
define-minor-mode defun* defmacro*)
"`defun'-like operators that use `autoload' to load the library.")
-
+
(defvar autoload-make-autoload-complex-operators
'(easy-mmode-define-minor-mode easy-mmode-define-global-mode
define-minor-mode)
"`defun'-like operators to macroexpand before using `autoload'.")
-
+
(put 'autoload 'doc-string-elt 3)
(put 'defun 'doc-string-elt 3)
(put 'defun* 'doc-string-elt 3)
(setq file (expand-file-name file))
;; #### FSF 21.2. Do we want this?
; (let* ((source-truename (file-truename file))
-; (dir-truename (file-name-as-directory
-; (file-truename default-directory)))
-; (len (length dir-truename)))
+; (dir-truename (file-name-as-directory
+; (file-truename default-directory)))
+; (len (length dir-truename)))
; (if (and (< len (length source-truename))
-; (string= dir-truename (substring source-truename 0 len)))
-; (setq file (substring source-truename len))))
+; (string= dir-truename (substring source-truename 0 len)))
+; (setq file (substring source-truename len))))
;; Check for suppression form (XEmacs)
(let* ((dir (file-name-directory file))
;; place we need the syntax table is when snarfing the Lisp
;; function name.
(set-syntax-table emacs-lisp-mode-syntax-table))
-; (if visited
-; (set-buffer visited)
-; ;; It is faster to avoid visiting the file.
-; (set-buffer (get-buffer-create " *generate-autoload-file*"))
-; (kill-all-local-variables)
-; (erase-buffer)
-; (setq buffer-undo-list t
-; buffer-read-only nil)
-; ;; This doesn't look right for C files, but it is. The only
-; ;; place we need the syntax table is when snarfing the Lisp
-; ;; function name.
-; (emacs-lisp-mode)
-; (if literal
-; (insert-file-contents-literally file nil)
-; (insert-file-contents file nil)))
+; (if visited
+; (set-buffer visited)
+; ;; It is faster to avoid visiting the file.
+; (set-buffer (get-buffer-create " *generate-autoload-file*"))
+; (kill-all-local-variables)
+; (erase-buffer)
+; (setq buffer-undo-list t
+; buffer-read-only nil)
+; ;; This doesn't look right for C files, but it is. The only
+; ;; place we need the syntax table is when snarfing the Lisp
+; ;; function name.
+; (emacs-lisp-mode)
+; (if literal
+; (insert-file-contents-literally file nil)
+; (insert-file-contents file nil)))
(unless (setq autoloads-done
(funcall fun-to-call outbuf load-name trim-name))
(return-from generate-autoload-type-section))
;; we alone and our successors can update the file. The file itself
;; will work fine in older XEmacsen, but they won't be able to
;; update autoloads -- hence, to build.
-; ;; Break that line at spaces, to avoid very long lines.
-; ;; Make each sub-line into a comment.
-; (with-current-buffer outbuf
-; (save-excursion
-; (forward-line -1)
-; (while (not (eolp))
-; (move-to-column 64)
-; (skip-chars-forward "^ \n")
-; (or (eolp)
-; (insert "\n" generate-autoload-section-continuation)))))
+; ;; Break that line at spaces, to avoid very long lines.
+; ;; Make each sub-line into a comment.
+; (with-current-buffer outbuf
+; (save-excursion
+; (forward-line -1)
+; (while (not (eolp))
+; (move-to-column 64)
+; (skip-chars-forward "^ \n")
+; (or (eolp)
+; (insert "\n" generate-autoload-section-continuation)))))
;; XEmacs: This was commented out before. #### Correct?
-; (insert ";;; Generated autoloads from "
-; (autoload-trim-file-name file) "\n")
+; (insert ";;; Generated autoloads from "
+; (autoload-trim-file-name file) "\n")
;; XEmacs -- handle suppression
(when suppress-form
(insert "\n;;; Suppress form from _pkg.el\n")
(symbol-value-in-buffer 'default-directory
outbuf)) outbuf)
(princ ")\n" outbuf)
-
+
(goto-char (point-min))
(while (not (eobp))
(skip-chars-forward " \t\n\f")
"Returns relative pathname of FILE including the last directory."
(setq file (expand-file-name file))
(file-relative-name file (file-name-directory
- (directory-file-name
- (file-name-directory file)))))
+ (directory-file-name
+ (file-name-directory file)))))
(defun autoload-read-section-header ()
"Read a section header form.
;; up-to-date and recompile when we build.
;; FSF 21.2: [not applicable to XEmacs]
-; (or (> (buffer-size) 0)
-; (error "Autoloads file %s does not exist" buffer-file-name))
-; (or (file-writable-p buffer-file-name)
-; (error "Autoloads file %s is not writable" buffer-file-name))
+; (or (> (buffer-size) 0)
+; (error "Autoloads file %s does not exist" buffer-file-name))
+; (or (file-writable-p buffer-file-name)
+; (error "Autoloads file %s is not writable" buffer-file-name))
;; NOTE: The rest of this function is totally changed from FSF.
;; Hence, not synched.
(defun parse-command-line (cmdl)
(let ((newcmdl (dllist))
- (cmdlpl (make-skiplist))
- (mm (compile-regexp "^--"))
- (ign (compile-regexp #r"^-\(?:batch\|nd\|vanilla\)"))
- (ign2 (compile-regexp "^-[lf]$")))
+ (cmdlpl (make-skiplist))
+ (mm (compile-regexp "^--"))
+ (ign (compile-regexp #r"^-\(?:batch\|nd\|vanilla\)"))
+ (ign2 (compile-regexp "^-[lf]$")))
(while (car cmdl)
(cond ((string-match mm (car cmdl))
- (let ((key (intern (car cmdl)))
- (val (car (cdr-safe cmdl))))
- (put-skiplist cmdlpl key val)
- (setq cmdl (cdr-safe cmdl))))
- ((string-match ign2 (car cmdl))
- ;; ignore a pair of parameters
- (setq cmdl (cdr-safe cmdl)))
- ((string-match ign (car cmdl))
- ;; ignore this single parameter
- )
- (t
- (dllist-append newcmdl (car cmdl))))
+ (let ((key (intern (car cmdl)))
+ (val (car (cdr-safe cmdl))))
+ (put-skiplist cmdlpl key val)
+ (setq cmdl (cdr-safe cmdl))))
+ ((string-match ign2 (car cmdl))
+ ;; ignore a pair of parameters
+ (setq cmdl (cdr-safe cmdl)))
+ ((string-match ign (car cmdl))
+ ;; ignore this single parameter
+ )
+ (t
+ (dllist-append newcmdl (car cmdl))))
(setq cmdl (cdr-safe cmdl)))
(put newcmdl :tweaks cmdlpl)
newcmdl))
(error "batch-update-directory-autoloads: may be used only with -batch"))
(let* ((cmds (parse-command-line (cdr-safe command-line-args)))
- (pl (get cmds :tweaks)))
+ (pl (get cmds :tweaks)))
(unless (get-skiplist pl '--autoload-dir-name)
(put-skiplist pl '--autoload-dir-name
- (expand-file-name default-directory)))
+ (expand-file-name default-directory)))
(unless (get-skiplist pl '--autoload-file-name)
(put-skiplist pl '--autoload-file-name
- (expand-file-name autoload-file-name
- (get-skiplist pl '--autoload-dir-name))))
+ (expand-file-name autoload-file-name
+ (get-skiplist pl '--autoload-dir-name))))
(unless (get-skiplist pl '--feature-prefix)
(put-skiplist pl '--feature-prefix
- (file-name-nondirectory
- (directory-file-name
- (expand-file-name
- (get-skiplist pl '--autoload-dir-name))))))
+ (file-name-nondirectory
+ (directory-file-name
+ (expand-file-name
+ (get-skiplist pl '--autoload-dir-name))))))
(create-autoload-files cmds t)))
(defun create-autoload-files (bunch &optional force)
(let* ((pl (get bunch :tweaks))
- (relative (get-skiplist pl '--relative-to))
- (al-file (get-skiplist pl '--autoload-file-name))
- (fprefix (get-skiplist pl '--feature-prefix)))
+ (relative (get-skiplist pl '--relative-to))
+ (al-file (get-skiplist pl '--autoload-file-name))
+ (fprefix (get-skiplist pl '--feature-prefix)))
(mapc-inplace
#'(lambda (dir)
- (expand-file-name dir relative))
+ (expand-file-name dir relative))
bunch)
(update-autoload-files (dllist-to-list bunch) fprefix al-file force)))
Here is how to use backquotes:
(setq p 'b
- q '(c d e))
+ q '(c d e))
`(a ,p ,@q) -> (a b c d e)
`(a . b) -> (a . b)
`(a . ,p) -> (a . b)
(cond ((eq dflag 'append)
(cons a d ))
(t (list a (bq-process-1 dflag d)))))))
- ((eq aflag bq-dot-flag)
- (if (null dflag)
- (bq-comma a)
- (cons 'nconc
- (cond ((eq dflag 'nconc)
- (cons a d))
- (t (list a (bq-process-1 dflag d)))))))
+ ((eq aflag bq-dot-flag)
+ (if (null dflag)
+ (bq-comma a)
+ (cons 'nconc
+ (cond ((eq dflag 'nconc)
+ (cons a d))
+ (t (list a (bq-process-1 dflag d)))))))
((null dflag)
(if (memq aflag '(quote t nil))
(cons 'quote (list a))
(progn (delete-char 1)
(insert ? ))
(delete-region (point) (progn (forward-line 1) (point)))
- (backward-char 1))))))
+ (backward-char 1))))))
(defun Buffer-menu-select ()
"Select this line's buffer; also display buffers marked with `>'.
(other-window 1)
(switch-to-buffer (car others))
(setq others (cdr others)))
- (other-window 1) ;back to the beginning!
+ (other-window 1) ;back to the beginning!
)))
(beginning-of-line)
(forward-char 2)
(if (/= (following-char) char)
- (let (buffer-read-only)
- (delete-char 1)
- (insert char))))))
+ (let (buffer-read-only)
+ (delete-char 1)
+ (insert char))))))
;; XEmacs
(defvar Buffer-menu-popup-menu
;; #### not synched
(defun list-buffers-internal (output &optional predicate)
(let ((current (current-buffer))
- (buffers (buffer-list)))
+ (buffers (buffer-list)))
(save-excursion
(set-buffer output)
(setq buffer-read-only nil)
(insert list-buffers-header-line)
(while buffers
- (let* ((col1 19)
- (buffer (car buffers))
- (name (buffer-name buffer))
+ (let* ((col1 19)
+ (buffer (car buffers))
+ (name (buffer-name buffer))
this-buffer-line-start)
- (setq buffers (cdr buffers))
- (cond ((null name)) ;deleted buffer
- ((and predicate
- (not (if (stringp predicate)
- (string-match predicate name)
- (funcall predicate buffer))))
- nil)
- (t
- (set-buffer buffer)
- (let ((ro buffer-read-only)
- (id list-buffers-identification))
- (set-buffer output)
+ (setq buffers (cdr buffers))
+ (cond ((null name)) ;deleted buffer
+ ((and predicate
+ (not (if (stringp predicate)
+ (string-match predicate name)
+ (funcall predicate buffer))))
+ nil)
+ (t
+ (set-buffer buffer)
+ (let ((ro buffer-read-only)
+ (id list-buffers-identification))
+ (set-buffer output)
(setq this-buffer-line-start (point))
- (insert (if (eq buffer current)
- (progn (setq current (point)) ?\.)
- ?\ ))
- (insert (if (buffer-modified-p buffer)
- ?\*
- ?\ ))
- (insert (if ro
- ?\%
- ?\ ))
- (if (string-match "[\n\"\\ \t]" name)
- (let ((print-escape-newlines t))
- (prin1 name output))
- (insert ?\ name))
- (indent-to col1 1)
- (cond ((stringp id)
- (insert id))
- (id
- (set-buffer buffer)
- (condition-case e
- (funcall id output)
- (error
- (princ "***" output) (prin1 e output)))
- (set-buffer output)
- (goto-char (point-max)))))
+ (insert (if (eq buffer current)
+ (progn (setq current (point)) ?\.)
+ ?\ ))
+ (insert (if (buffer-modified-p buffer)
+ ?\*
+ ?\ ))
+ (insert (if ro
+ ?\%
+ ?\ ))
+ (if (string-match "[\n\"\\ \t]" name)
+ (let ((print-escape-newlines t))
+ (prin1 name output))
+ (insert ?\ name))
+ (indent-to col1 1)
+ (cond ((stringp id)
+ (insert id))
+ (id
+ (set-buffer buffer)
+ (condition-case e
+ (funcall id output)
+ (error
+ (princ "***" output) (prin1 e output)))
+ (set-buffer output)
+ (goto-char (point-max)))))
(put-nonduplicable-text-property this-buffer-line-start
(point)
'buffer-name name)
(put-nonduplicable-text-property this-buffer-line-start
(point)
'highlight t)
- (insert ?\n)))))
+ (insert ?\n)))))
(Buffer-menu-mode)
(if (not (bufferp current))
- (goto-char current)))))
+ (goto-char current)))))
;(define-key ctl-x-map "\C-b" 'list-buffers)
(defun list-buffers (&optional files-only)
;; emods
(defun find-emod-directories ()
(let* ((objdir "../modules/")
- (files (directory-files-recur
+ (files (directory-files-recur
objdir 'full (mapfam
#'(lambda (e)
(replace-in-string e "\\." ""))
(when (featurep 'modules)
(let* ((modsrc "../.sxemacs.source.tree/modules/")
- (mods (mapfam
+ (mods (mapfam
#'(lambda (d) (concat modsrc d))
:result-type #'list (find-emod-directories)))
(feat "modules")
"*The list of mail addresses SXEmacs Build Reports should most likely
go to."
:type '(repeat
- :custom-show t
- :documentation-shown t
- string)
+ :custom-show t
+ :documentation-shown t
+ string)
:group 'build-rpt)
(defcustom build-rpt-keep-regexp
"^\\(real\\|user\\|sys\\)\\s-+[0-9]+m")
"*Regexp of make process output lines to keep in the report."
:type '(repeat
- :custom-show t
- :documentation-shown t
- regexp)
+ :custom-show t
+ :documentation-shown t
+ regexp)
:group 'build-rpt)
(defcustom build-rpt-delete-regexp
"wrong-error")
"*Regexp of make process output lines to delete from the report."
:type '(repeat
- :custom-show t
- :documentation-shown t
- regexp)
+ :custom-show t
+ :documentation-shown t
+ regexp)
:group 'build-rpt)
(defcustom build-rpt-make-output-dir (config-value 'sxe_blddir)
"*Directory where the build report file is found."
:type '(directory
- :custom-show t
- :documentation-shown t)
+ :custom-show t
+ :documentation-shown t)
:group 'build-rpt)
(defcustom build-rpt-make-output-files
(list
",,vars.out"
",,beta.out"
- ",,make-all.out"
+ ",,make-all.out"
",,make-check-temacs.out"
",,make-check.out"
",,make-install.out")
$ make check 2>&1 | tee ,,make-check.out
"
:type '(repeat
- :custom-show t
- :documentation-shown t
- file)
+ :custom-show t
+ :documentation-shown t
+ file)
:group 'build-rpt)
(defcustom build-rpt-installation-file
(expand-file-name "Installation"
- (gethash 'sxe_blddir (config-value-hash-table)))
+ (gethash 'sxe_blddir (config-value-hash-table)))
"*Installation file produced by SXEmacs configure process."
:type '(file
- :custom-show t
- :documentation-shown t)
+ :custom-show t
+ :documentation-shown t)
:group 'build-rpt)
(defcustom build-rpt-version-file
"src"))))
"*File containing version info."
:type '(file
- :custom-show t
- :documentation-shown t)
+ :custom-show t
+ :documentation-shown t)
:group 'build-rpt)
(defcustom build-rpt-subject
with user input through `build-rpt' according to
`build-rpt-prompts' using `format'."
:type '(string
- :custom-show t
- :documentation-shown t)
+ :custom-show t
+ :documentation-shown t)
:group 'build-rpt)
(defcustom build-rpt-prompts
followed by any number of strings which can be chosen via the history
mechanism."
:type '(repeat
- :custom-show t
- :documentation-shown t
- (list
- :tag "Prompt"
- string
- (repeat
- :tag "Values"
- string)))
+ :custom-show t
+ :documentation-shown t
+ (list
+ :tag "Prompt"
+ string
+ (repeat
+ :tag "Values"
+ string)))
:group 'build-rpt)
(defcustom build-rpt-file-encoding
"Returns the filename the SXEmacs make output is saved in."
(interactive)
(if (or (string-equal build-rpt-make-output-dir "")
- (null build-rpt-make-output-dir))
+ (null build-rpt-make-output-dir))
(mapcar
(function
- (lambda (f)
- (expand-file-name
- f
- (file-name-as-directory
- (gethash 'sxe_blddir (config-value-hash-table))))))
+ (lambda (f)
+ (expand-file-name
+ f
+ (file-name-as-directory
+ (gethash 'sxe_blddir (config-value-hash-table))))))
build-rpt-make-output-files)
(mapcar
(function
(lambda (f)
- (expand-file-name
- f
- (file-name-as-directory build-rpt-make-output-dir))))
+ (expand-file-name
+ f
+ (file-name-as-directory build-rpt-make-output-dir))))
build-rpt-make-output-files)))
(defun build-rpt-read-destination ()
(if (and (interactive-p)
(featurep 'sendmail))
(user-mail-address)
- (concat (user-real-login-name)
- "-notconfigured@"
+ (concat (user-real-login-name)
+ "-notconfigured@"
(if mail-host-address
mail-host-address
"localhost"))))))
nil
nil)
(goto-char (point-max))
- (re-search-backward mail-header-separator)
- (next-line 1))
+ (re-search-backward mail-header-separator)
+ (next-line 1))
(pop-to-buffer "*build-rpt*")
(insert (format (concat "Please save this buffer to a file and email it\n"
- "Or, alternatively, rerun `M-x build-rpt' after installing the\n"
- "\"mail-lib\" XEmacs package.\n\n"
- "To: SXEmacs Builds <sxemacs-builds@sxemacs.org>\n"
- "Subject: %s\n\n")
- (apply #'format build-rpt-subject args)))))
+ "Or, alternatively, rerun `M-x build-rpt' after installing the\n"
+ "\"mail-lib\" XEmacs package.\n\n"
+ "To: SXEmacs Builds <sxemacs-builds@sxemacs.org>\n"
+ "Subject: %s\n\n")
+ (apply #'format build-rpt-subject args)))))
(let* ((rpt-begin (point))
- (files (reverse (build-rpt-make-output-get)))
- (file (car files)))
+ (files (reverse (build-rpt-make-output-get)))
+ (file (car files)))
(while file
- (if (file-exists-p file)
- (insert (build-rpt-insert-make-output rpt-begin file))
- (insert (format "%s not found!\n" file)))
- (insert "\n")
- (setq files (cdr files))
- (setq file (car files)))
+ (if (file-exists-p file)
+ (insert (build-rpt-insert-make-output rpt-begin file))
+ (insert (format "%s not found!\n" file)))
+ (insert "\n")
+ (setq files (cdr files))
+ (setq file (car files)))
(insert (build-rpt-insert-config-values rpt-begin))
(insert "\n")
(insert (build-rpt-insert-ldd rpt-begin))
(insert "\n")
(if (file-exists-p build-rpt-installation-file)
- (insert (build-rpt-insert-installation-file rpt-begin))
- (insert (format "%s not found!\n" build-rpt-installation-file)))
+ (insert (build-rpt-insert-installation-file rpt-begin))
+ (insert (format "%s not found!\n" build-rpt-installation-file)))
(insert "\n")
(insert (build-rpt-insert-header rpt-begin))
(if build-rpt-interactive
;; `interactive' form returns value for formal parameter `args'.
(interactive
(let (prompt
- hist
- arg
- (prompts build-rpt-prompts))
+ hist
+ arg
+ (prompts build-rpt-prompts))
(progn
(while prompts
- (defvar hist)
- (setq prompt (caar prompts))
- (setq hist (cdar prompts))
- ;; `build-rpt-prompts' used to be a list of lists, the
- ;; first element of each list being the prompt, the rest being
- ;; the history. The history is now in a separate list. We
- ;; better check for that.
- (if (listp (car hist))
- (setq hist (car hist)))
- (setq prompts (cdr prompts))
- (setq arg (cons (read-string prompt "" 'hist) arg)))
+ (defvar hist)
+ (setq prompt (caar prompts))
+ (setq hist (cdar prompts))
+ ;; `build-rpt-prompts' used to be a list of lists, the
+ ;; first element of each list being the prompt, the rest being
+ ;; the history. The history is now in a separate list. We
+ ;; better check for that.
+ (if (listp (car hist))
+ (setq hist (car hist)))
+ (setq prompts (cdr prompts))
+ (setq arg (cons (read-string prompt "" 'hist) arg)))
arg)))
(let ((build-rpt-email (build-rpt-read-destination))
(build-rpt-interactive (interactive-p)))
(goto-char where)
(with-temp-buffer
(if (file-exists-p file)
- (progn
- (if (featurep 'mime-setup)
- (progn
- (mime-edit-insert-tag
- "text"
- "plain"
- (concat
- "\nContent-Disposition: attachment;"
- " filename=\""
- (file-name-nondirectory
- file)
- "\""))
- (mime-edit-insert-binary-file
- file
- build-rpt-file-encoding))
- (insert-file-contents file))
- (when build-rpt-keep-regexp
- (goto-char (point-min))
- (delete-non-matching-lines (build-rpt-keep)))
- (when build-rpt-delete-regexp
- (goto-char (point-min))
- (delete-matching-lines (build-rpt-delete)))
- (goto-char (point-min))
- (insert "\n")
- (insert
- (format "> Contents of %s\n" file)))
+ (progn
+ (if (featurep 'mime-setup)
+ (progn
+ (mime-edit-insert-tag
+ "text"
+ "plain"
+ (concat
+ "\nContent-Disposition: attachment;"
+ " filename=\""
+ (file-name-nondirectory
+ file)
+ "\""))
+ (mime-edit-insert-binary-file
+ file
+ build-rpt-file-encoding))
+ (insert-file-contents file))
+ (when build-rpt-keep-regexp
+ (goto-char (point-min))
+ (delete-non-matching-lines (build-rpt-keep)))
+ (when build-rpt-delete-regexp
+ (goto-char (point-min))
+ (delete-matching-lines (build-rpt-delete)))
+ (goto-char (point-min))
+ (insert "\n")
+ (insert
+ (format "> Contents of %s\n" file)))
(insert "> " file
- " does not exist!\n\n"))
+ " does not exist!\n\n"))
(buffer-string)))
(defun build-rpt-insert-installation-file (where)
(with-temp-buffer
(if (file-exists-p build-rpt-installation-file)
(progn
- (insert "> Contents of "
- build-rpt-installation-file
- ":\n")
- (insert "> (Output from ./configure)\n\n")
- (if (featurep 'mime-setup)
- (progn
- (mime-edit-insert-tag
- "text"
- "plain"
- (concat
- "\nContent-Disposition: attachment;"
- " filename=\""
- (file-name-nondirectory
- build-rpt-installation-file)
- "\""))
- (mime-edit-insert-binary-file
- build-rpt-installation-file
- build-rpt-file-encoding))
- (insert-file-contents
- build-rpt-installation-file)))
+ (insert "> Contents of "
+ build-rpt-installation-file
+ ":\n")
+ (insert "> (Output from ./configure)\n\n")
+ (if (featurep 'mime-setup)
+ (progn
+ (mime-edit-insert-tag
+ "text"
+ "plain"
+ (concat
+ "\nContent-Disposition: attachment;"
+ " filename=\""
+ (file-name-nondirectory
+ build-rpt-installation-file)
+ "\""))
+ (mime-edit-insert-binary-file
+ build-rpt-installation-file
+ build-rpt-file-encoding))
+ (insert-file-contents
+ build-rpt-installation-file)))
(insert "> " build-rpt-installation-file
- " does not exist!\n\n"))
+ " does not exist!\n\n"))
(buffer-string)))
(defun build-rpt-insert-config-values (where)
(goto-char where)
(with-temp-buffer
(if (null (config-value-hash-table))
- (insert "> `config-value-hash-table' is empty, which is weird :(!\n\n")
+ (insert "> `config-value-hash-table' is empty, which is weird :(!\n\n")
(progn
- (insert "> Contents of `config-value-hash-table':\n")
- (let ((curp (point))
- value-empty)
- (maphash
- #'(lambda (key value)
- (if (and (stringp value)
- (string= "" value))
- (setq value-empty (cons key value-empty))
- (insert (format "%s %S\n" key value))))
- (config-value-hash-table))
- (goto-char curp)
- ;; we are at `curp' again
- (insert (format "Empty keys: %s\n\n"
- (mapconcat #'prin1-to-string
- value-empty " "))))))
+ (insert "> Contents of `config-value-hash-table':\n")
+ (let ((curp (point))
+ value-empty)
+ (maphash
+ #'(lambda (key value)
+ (if (and (stringp value)
+ (string= "" value))
+ (setq value-empty (cons key value-empty))
+ (insert (format "%s %S\n" key value))))
+ (config-value-hash-table))
+ (goto-char curp)
+ ;; we are at `curp' again
+ (insert (format "Empty keys: %s\n\n"
+ (mapconcat #'prin1-to-string
+ value-empty " "))))))
(buffer-string)))
(defun build-rpt-insert-ldd (where)
(goto-char where)
(with-temp-buffer
(let ((running-binary-tests
- '((lambda ()
- (expand-file-name (car command-line-args)
- command-line-default-directory))
- (lambda ()
- (locate-file (car command-line-args)
- (split-string (getenv "PATH") ":")))))
- (running-binary)
- (ldd
- (let ((sysconfl (split-string system-configuration "-")))
- (cond
- ((member "apple" sysconfl)
- "otool -XL")
- (t
- "ldd")))))
+ '((lambda ()
+ (expand-file-name (car command-line-args)
+ command-line-default-directory))
+ (lambda ()
+ (locate-file (car command-line-args)
+ (split-string (getenv "PATH") ":")))))
+ (running-binary)
+ (ldd
+ (let ((sysconfl (split-string system-configuration "-")))
+ (cond
+ ((member "apple" sysconfl)
+ "otool -XL")
+ (t
+ "ldd")))))
;; perform binary finder tests
(while (and (null running-binary) (car-safe running-binary-tests))
- (let ((candidate (funcall (car running-binary-tests))))
- (setq running-binary
- (and candidate
- (file-exists-p candidate)
- candidate)
- running-binary-tests (cdr running-binary-tests))))
+ (let ((candidate (funcall (car running-binary-tests))))
+ (setq running-binary
+ (and candidate
+ (file-exists-p candidate)
+ candidate)
+ running-binary-tests (cdr running-binary-tests))))
(if (null running-binary)
- (insert "cannot obtain ld-dependencies.\n")
- (insert (shell-command-to-string (concat ldd " " running-binary)))
- (goto-char (point-min))
- (while (re-search-forward "^\\s-+" nil t)
- (replace-match "")))
+ (insert "cannot obtain ld-dependencies.\n")
+ (insert (shell-command-to-string (concat ldd " " running-binary)))
+ (goto-char (point-min))
+ (while (re-search-forward "^\\s-+" nil t)
+ (replace-match "")))
(goto-char (point-min))
(insert "> shared library dependencies:\n"))
(buffer-string)))
MIME tag REGEXP. The result is a REGEXP string matching either of the
REGEXPs in `build-rpt-keep-regexp' or a general MIME tag REGEXP."
(mapconcat #'identity
- (cons #r"^--\[\[\|\]\]$" build-rpt-keep-regexp) "\\|"))
+ (cons #r"^--\[\[\|\]\]$" build-rpt-keep-regexp) "\\|"))
(defun build-rpt-delete ()
"Concatenate elements of `build-rpt-delete-regexp' and a general
MIME tag REGEXP. The result is a REGEXP string matching either of the
REGEXPs in `build-rpt-delete-regexp' or a general MIME tag REGEXP."
(mapconcat '(lambda (item) item)
- build-rpt-delete-regexp "\\|"))
+ build-rpt-delete-regexp "\\|"))
;; To ensure we always get the right build reporter, alias the
;; incompatible one to ours if it is ever loaded.
((and (fboundp 'compiler-macroexpand)
(symbolp (car-safe form))
(get (car-safe form) 'cl-compiler-macro)
- (not (eq form
- (setq form (compiler-macroexpand form)))))
+ (not (eq form
+ (setq form (compiler-macroexpand form)))))
(byte-optimize-form form for-effect))
((not (symbolp fn))
;; Byte-compiled code with special number types is not readable by
;; SXEmacsen which do not have an mp spine.
;; Therefore always tag their usage using (featurep 'ent)
-;; or the like
+;; or the like
;; - hroptatyr
(defun byte-optimize-delay-constants-math (form start fun)
;; Merge all FORM's constants from number START, call FUN on them
(overflow (memq fun '(+ *))))
(while (cdr (setq rest (cdr rest)))
(if (if (featurep 'ent)
- (numberp (car rest))
- (integerp (car rest)))
+ (numberp (car rest))
+ (integerp (car rest)))
(let (constants)
(setq form (copy-sequence form)
rest (nthcdr (1- start) form))
(while (setq rest (cdr rest))
(cond ((and (featurep 'ent)
- (rationalp (car rest)))
- (setq constants (cons (car rest) constants))
- (setcar rest nil))
- ((integerp (car rest))
- (setq constants (cons (car rest) constants))
- (setcar rest nil))
- ((realp (car rest))
+ (rationalp (car rest)))
+ (setq constants (cons (car rest) constants))
+ (setcar rest nil))
+ ((integerp (car rest))
+ (setq constants (cons (car rest) constants))
+ (setcar rest nil))
+ ((realp (car rest))
(setq constants
(cons
(coerce-number
)))
constants))
(setcar rest nil))
- ((and (or (featurep 'bigc)
- (featurep 'bigg))
- (complexp (car rest)))
- (setq constants (cons (car rest) constants))
- (setcar rest nil))
- ((and (featurep 'resclass)
- (declare-fboundp (residue-class-p (car rest))))
- (setq constants (cons (car rest) constants))
- (setcar rest nil))))
+ ((and (or (featurep 'bigc)
+ (featurep 'bigg))
+ (complexp (car rest)))
+ (setq constants (cons (car rest) constants))
+ (setcar rest nil))
+ ((and (featurep 'resclass)
+ (declare-fboundp (residue-class-p (car rest))))
+ (setq constants (cons (car rest) constants))
+ (setcar rest nil))))
;; If necessary, check now for overflow
;; that might be caused by reordering.
(if (and overflow
;; We have overflow if the result of doing the arithmetic
;; on floats is not even close to the result
;; of doing it on integers.
- (not (featurep '(or bigz bigq bigf bigfr bigc bigg resclass)))
- ;; This assumption, of course, is not valid if we
- ;; have bigz numbers
+ (not (featurep '(or bigz bigq bigf bigfr bigc bigg resclass)))
+ ;; This assumption, of course, is not valid if we
+ ;; have bigz numbers
(not (byte-optimize-approx-equal
(apply fun (mapcar 'float constants))
(float (apply fun constants)))))
(cond ((numberp (nth 1 form))
(eval form))
((featurep 'ent)
- ;; we cannot compare to 0 anymore, since there are coercion
- ;; issues and even non-comparable types
- form)
- (byte-compile-delete-errors
+ ;; we cannot compare to 0 anymore, since there are coercion
+ ;; issues and even non-comparable types
+ form)
+ (byte-compile-delete-errors
(list '= (nth 1 form) 0))
(form)))
(setq rest (cdr rest))
(cond ((= tmp 1)
(byte-compile-log-lap
- " %s discard\t-->\t<deleted>" lap0)
+ " %s discard\t-->\t<deleted>" lap0)
(setq lap (delq lap0 (delq lap1 lap))))
((= tmp 0)
(byte-compile-log-lap
(byte-compile-log-lap
" %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s"
(nth 1 (cdr lap2)) (car tmp)
- lap1 lap2
+ lap1 lap2
(nth 1 (cdr lap2)) (car tmp)
(nth 1 newtag) 'byte-dup lap1
(cons 'byte-goto newtag)
lap1 (nth 1 rest))
(if (memq (car lap0) byte-constref-ops)
(if (not (eq (car lap0) 'byte-constant))
- (progn
+ (progn
(incf (gethash (cdr lap0) variable-frequency 0))
(or (memq (cdr lap0) byte-compile-variables)
(setq byte-compile-variables
;; This file is dumped with SXEmacs.
-;; The code in this file should always be loaded, because it defines things
-;; like "defsubst" which should work interpreted as well. The code in
+;; The code in this file should always be loaded, because it defines things
+;; like "defsubst" which should work interpreted as well. The code in
;; bytecomp.el and byte-optimize.el can be loaded as needed.
;; interface to selectively inlining functions.
(put 'byte-compiler-options 'lisp-indent-hook 0)
(defmacro byte-compiler-options (&rest args)
- "Set some compilation-parameters for this file.
+ "Set some compilation-parameters for this file.
This will affect only the file in which it appears; this does nothing when
evaluated, or when loaded from a .el file.
obsolete use of an obsolete function or variable.
pedantic warn of use of compatible symbols.
-If the first element if the list is `+' or `-' then the specified elements
+If the first element if the list is `+' or `-' then the specified elements
are added to or removed from the current set of warnings, instead of the
entire set of warnings being overwritten.
(and (cdr sig) (> max (cdr sig))))
(byte-compile-warn
"%s being defined to take %s%s, but was previously called with %s"
- (nth 1 form)
+ (nth 1 form)
(byte-compile-arglist-signature-string sig)
(if (equal sig '(1 . 1)) " arg" " args")
(byte-compile-arglist-signature-string (cons min max))))
(y-or-n-p (concat "Compile " source "? "))))))
(progn ;(if (and noninteractive (not byte-compile-verbose))
; (message "Compiling %s..." source))
- ; we do this in byte-compile-file.
- (if byte-recompile-directory-ignore-errors-p
+ ; we do this in byte-compile-file.
+ (if byte-recompile-directory-ignore-errors-p
(batch-byte-compile-1 source)
(byte-compile-file source))
(or noninteractive
(let ((buffer-file-name filename)
(default-major-mode 'emacs-lisp-mode)
(enable-local-eval nil))
- (normal-mode)
- (setq filename buffer-file-name)))
+ (normal-mode)
+ (setq filename buffer-file-name)))
(setq byte-compiler-error-flag nil)
;; It is important that input-buffer not be current at this call,
;; so that the value of point set in input-buffer
"\t (or (and (boundp 'epoch::version) epoch::version)\n"
"\t (and (not (featurep 'xemacs))\n"
"\t (<= emacs-major-version 19)\n"
- "\t (< emacs-minor-version 29))\n"
+ "\t (< emacs-minor-version 29))\n"
"\t (and (<= emacs-major-version 20)\n"
- "\t (< emacs-minor-version 14))))\n"
+ "\t (< emacs-minor-version 14))))\n"
" (error \"`"
;; prin1-to-string is used to quote backslashes.
(substring (prin1-to-string (file-name-nondirectory filename))
((and (fboundp name)
(or (subrp (symbol-function name))
(eq (car-safe (symbol-function name))
- (if macrop 'lambda 'macro))))
+ (if macrop 'lambda 'macro))))
(if (memq 'redefine byte-compile-warnings)
(byte-compile-warn "%s %s being redefined as a %s"
(if (subrp (symbol-function name))
;; XEmacs change; our implementation byte compiles and gives warnings
;; about the default value code, which GNU's doesn't.
(let* ((quoted-default (car-safe (cdr-safe (cdr-safe form))))
- (to-examine (car-safe (cdr-safe quoted-default))))
+ (to-examine (car-safe (cdr-safe quoted-default))))
(if (memq 'free-vars byte-compile-warnings)
- (setq byte-compile-bound-variables
- (cons (cons (nth 1 (nth 1 form))
- byte-compile-global-bit)
- byte-compile-bound-variables)))
+ (setq byte-compile-bound-variables
+ (cons (cons (nth 1 (nth 1 form))
+ byte-compile-global-bit)
+ byte-compile-bound-variables)))
;; Byte compile anything that smells like a lambda. I initially
;; considered limiting it to the :initialize, :set and :get args, but
;; that's not amazingly forward-compatible, and anyone expecting other
- ;; things to be stored as data, not code, is unrealistic.
+ ;; things to be stored as data, not code, is unrealistic.
(loop
for entry in-ref (nthcdr 4 form)
do (cond ((and (eq 'function (car-safe entry))
- (consp (car-safe (cdr-safe entry))))
- (setf entry (copy-sequence entry))
- (setcar (cdr entry) (byte-compile-lambda (car (cdr entry)))))
- ((and (eq 'lambda (car-safe entry)))
- (setf entry (byte-compile-lambda entry)))))
- ;; Byte compile the default value, as we do for defvar.
+ (consp (car-safe (cdr-safe entry))))
+ (setf entry (copy-sequence entry))
+ (setcar (cdr entry) (byte-compile-lambda (car (cdr entry)))))
+ ((and (eq 'lambda (car-safe entry)))
+ (setf entry (byte-compile-lambda entry)))))
+ ;; Byte compile the default value, as we do for defvar.
(when (consp (cdr-safe to-examine))
(setq form (copy-sequence form))
(setcdr (third form)
- (list (byte-compile-top-level to-examine nil 'file)))
+ (list (byte-compile-top-level to-examine nil 'file)))
;; And save a value to be examined in the custom UI, if that differs
;; from the init value.
(unless (equal to-examine (car-safe (cdr (third form))))
- (setf (nthcdr 4 form) (nconc
- (list :default
- (list 'quote to-examine))
- (nthcdr 4 form)))))
+ (setf (nthcdr 4 form) (nconc
+ (list :default
+ (list 'quote to-examine))
+ (nthcdr 4 form)))))
form))
\f
(while (cond
((memq (car (car rest)) '(byte-varref byte-constant))
(setq tmp (car (cdr (car rest))))
- (if (if (eq (car (car rest)) 'byte-constant)
- (or (consp tmp)
- (and (symbolp tmp)
- (not (byte-compile-constant-symbol-p tmp)))))
- (if maycall
- (setq body (cons (list 'quote tmp) body)))
- (setq body (cons tmp body))))
- ((and maycall
+ (if (if (eq (car (car rest)) 'byte-constant)
+ (or (consp tmp)
+ (and (symbolp tmp)
+ (not (byte-compile-constant-symbol-p tmp)))))
+ (if maycall
+ (setq body (cons (list 'quote tmp) body)))
+ (setq body (cons tmp body))))
+ ((and maycall
;; Allow a funcall if at most one atom follows it.
(null (nthcdr 3 rest))
(setq tmp
(list 'quote
(or (car (cdr-safe function))
(intern (concat "byte-"
- (symbol-name (or (car-safe function) function))))))
+ (symbol-name (or (car-safe function) function))))))
''emacs20-opcode t)
(list 'byte-defop-compiler function compile-handler))))
(byte-defop-compiler integerp 1)
(byte-defop-compiler skip-chars-forward 1-2+1)
(byte-defop-compiler skip-chars-backward 1-2+1)
-(byte-defop-compiler (eql byte-eq) 2)
-(byte-defop-compiler20 old-eq 2)
+(byte-defop-compiler (eql byte-eq) 2)
+(byte-defop-compiler20 old-eq 2)
(byte-defop-compiler20 old-memq 2)
(byte-defop-compiler cons 2)
(byte-defop-compiler aref 2)
compiled-clauses)
(while clauses
(let* ((clause (car clauses))
- (condition (car clause)))
- (cond ((not (or (symbolp condition)
+ (condition (car clause)))
+ (cond ((not (or (symbolp condition)
(and (listp condition)
(let ((syms condition) (ok t))
(while syms
(setq ok nil))
(setq syms (cdr syms)))
ok))))
- (byte-compile-warn
- "%s is not a symbol naming a condition or a list of such (in condition-case)"
- (prin1-to-string condition)))
+ (byte-compile-warn
+ "%s is not a symbol naming a condition or a list of such (in condition-case)"
+ (prin1-to-string condition)))
;; ((not (or (eq condition 't)
;; (and (stringp (get condition 'error-message))
;; (consp (get condition 'error-conditions)))))
fun var string))
`(put ',var 'variable-documentation ,string))
(if (cdr (cdr form)) ; `value' provided
- (cond ((eq fun 'defconst)
- ;; `defconst' sets `var' unconditionally.
- `(setq ,var ,value))
- ((eq fun 'defregexp)
- ;; `defregexp' sets `var' unconditionally, too
- `(setq ,var (compile-regexp ,value)))
- (t
- ;; `defvar' sets `var' only when unbound.
- `(if (not (default-boundp ',var)) (set-default ',var ,value)))))
+ (cond ((eq fun 'defconst)
+ ;; `defconst' sets `var' unconditionally.
+ `(setq ,var ,value))
+ ((eq fun 'defregexp)
+ ;; `defregexp' sets `var' unconditionally, too
+ `(setq ,var (compile-regexp ,value)))
+ (t
+ ;; `defvar' sets `var' only when unbound.
+ `(if (not (default-boundp ',var)) (set-default ',var ,value)))))
`',var))))
(defun byte-compile-autoload (form)
(error "`batch-byte-compile-one-file-here' is to be used only with -batch"))
;; we hard-redefine it, since we ought to be called in batch mode only
(fset 'byte-compile-dest-file
- #'(lambda (filename)
- "Convert an Emacs Lisp source file name to a compiled file name."
- (let ((outfile
- (file-name-sans-extension
- (if (string-match "lisp/" filename)
- (substring filename (match-end 0))
- filename))))
- (expand-file-name (concat outfile ".elc") default-directory))))
+ #'(lambda (filename)
+ "Convert an Emacs Lisp source file name to a compiled file name."
+ (let ((outfile
+ (file-name-sans-extension
+ (if (string-match "lisp/" filename)
+ (substring filename (match-end 0))
+ filename))))
+ (expand-file-name (concat outfile ".elc") default-directory))))
(batch-byte-compile-one-file))
(defun batch-byte-compile-1 (file)
(defun safe-idiv (a b)
(let* ((q (/ (abs a) (abs b)))
- (s (* (signum a) (signum b))))
+ (s (* (signum a) (signum b))))
(Values q (- a (* s q b)) s)))
(provide 'cl-compat)
;;; cl-compat.el ends here
-
((and (eq type 'character) (stringp x) (= (length x) 1)) (aref x 0))
((and (eq type 'character) (symbolp x)) (coerce (symbol-name x) type))
((and (eq type 'character) (char-int-p x)) (int-char x))
- ((and (featurep 'number-types)
- (memq type '(int fixnum
- bigz bignum
- integer
- bigq ratio
- rational
- float
- bigf bigfloat
- bigfr
- real
- bigg
- bigc
- ;;complex
- ))
- (coerce-number x type)))
+ ((and (featurep 'number-types)
+ (memq type '(int fixnum
+ bigz bignum
+ integer
+ bigq ratio
+ rational
+ float
+ bigf bigfloat
+ bigfr
+ real
+ bigg
+ bigc
+ ;;complex
+ ))
+ (coerce-number x type)))
((and (eq type 'integer) (characterp x)) (char-int x))
((eq type 'float) (float x))
((eq type 'bit-vector) (if (bit-vector-p x) x
"Return the greatest common divisor of the arguments."
(let ((a (abs (or (cl-pop args) 0))))
(while args
- (let ((b (abs (cl-pop args))))
- (while (> b 0) (setq b (% a (setq a b))))))
+ (let ((b (abs (cl-pop args))))
+ (while (> b 0) (setq b (% a (setq a b))))))
a)))
(unless (fboundp #'lcm)
(defun lcm (&rest args)
"Return the least common multiple of the arguments."
(if (memq 0 args)
- 0
+ 0
(let ((a (abs (or (cl-pop args) 1))))
- (while args
- (let ((b (abs (cl-pop args))))
- (setq a (* (/ a (gcd a b)) b))))
- a))))
+ (while args
+ (let ((b (abs (cl-pop args))))
+ (setq a (* (/ a (gcd a b)) b))))
+ a))))
(defun isqrt (a)
"Return the integer square root of the argument."
(cond ((symbolp arg)
;; Do not upcase &optional, &key etc.
(if (memq arg lambda-list-keywords)
- arg
+ arg
(make-symbol (upcase (symbol-name arg)))))
((listp arg)
(let ((arg (copy-list arg)) junk)
(check-argument-type #'true-list-p arglist)
(let ((print-gensym nil))
(condition-case nil
- (prin1-to-string
- (cons (if (eq name 'cl-none) 'lambda name)
- (cond ((null arglist) nil)
- ((listp arglist) (cl-upcase-arg arglist))
- ((symbolp arglist)
- (cl-upcase-arg (list '&rest arglist)))
- (t (wrong-type-argument 'listp arglist)))))
+ (prin1-to-string
+ (cons (if (eq name 'cl-none) 'lambda name)
+ (cond ((null arglist) nil)
+ ((listp arglist) (cl-upcase-arg arglist))
+ ((symbolp arglist)
+ (cl-upcase-arg (list '&rest arglist)))
+ (t (wrong-type-argument 'listp arglist)))))
(t "Not available")))))
(defun cl-transform-lambda (form bind-block)
(bind-defs nil) (bind-enquote nil)
(bind-inits nil) (bind-lets nil) (bind-forms nil)
(header nil) (simple-args nil)
- (complex-arglist (cl-function-arglist bind-block args))
- (doc ""))
+ (complex-arglist (cl-function-arglist bind-block args))
+ (doc ""))
(while (or (stringp (car body)) (eq (car-safe (car body)) 'interactive))
(push (pop body) header))
(setq args (if (listp args) (copy-list args) (list '&rest args)))
(or (eq bind-block 'cl-none)
(setq body (list (list* 'block bind-block body))))
(setq simple-args (nreverse simple-args)
- header (nreverse header))
+ header (nreverse header))
;; Add CL lambda list to documentation, if the CL lambda list differs
;; from the non-CL lambda list. npak@ispras.ru
(unless (equal complex-arglist
- (cl-function-arglist bind-block simple-args))
+ (cl-function-arglist bind-block simple-args))
(and (stringp (car header)) (setq doc (pop header)))
(push (concat doc
- "\n\nCommon Lisp lambda list:\n"
- " " complex-arglist "\n\n")
+ "\n\nCommon Lisp lambda list:\n"
+ " " complex-arglist "\n\n")
header))
(if (null args)
(list* nil simple-args (nconc header body))
((memq word key-types)
(or (memq (car args) '(in of)) (error "Expected `of'"))
(let* ((map (cl-pop2 args))
- other-word
- (other (if (eq (car args) 'using)
- (if (and (= (length (cadr args)) 2)
- (memq (setq other-word (caadr args))
- key-types)
- (not (eq (caadr args) word)))
- (cadr (cl-pop2 args))
- (error "Bad `using' clause"))
- (gensym))))
+ other-word
+ (other (if (eq (car args) 'using)
+ (if (and (= (length (cadr args)) 2)
+ (memq (setq other-word (caadr args))
+ key-types)
+ (not (eq (caadr args) word)))
+ (cadr (cl-pop2 args))
+ (error "Bad `using' clause"))
+ (gensym))))
(when (memq word '(key-binding key-bindings))
- (setq var (prog1 other (setq other var)))
- (and other-word (setq word other-word)))
+ (setq var (prog1 other (setq other var)))
+ (and other-word (setq word other-word)))
(setq loop-map-form
(list (if (memq word '(key-seq key-seqs))
'cl-map-keymap-recursively 'cl-map-keymap)
((memq word '(bvconcat bvconcating))
(let ((what (cl-pop args))
- (var (cl-loop-handle-accum #*)))
- (cl-push (list 'progn (list 'callf 'bvconcat var what) t) loop-body)))
+ (var (cl-loop-handle-accum #*)))
+ (cl-push (list 'progn (list 'callf 'bvconcat var what) t) loop-body)))
((memq word '(sum summing))
(let ((what (cl-pop args))
definition is treated as if it were a setf.
A binding for a symbol macro can be shadowed by `let' or `symbol-macrolet'."
(cond ((not (symbolp symbol))
- (error "define-symbol-macro: %S is not a symbol"
- symbol))
- (t
- `(progn
- (put ',symbol 'symbol-macro ',expansion)
- ',symbol))))
+ (error "define-symbol-macro: %S is not a symbol"
+ symbol))
+ (t
+ `(progn
+ (put ',symbol 'symbol-macro ',expansion)
+ ',symbol))))
(defvar cl-closure-vars nil)
;;;###autoload
(defun print-custom-object (obj &optional stream pl)
"Print custom object OBJ into STREAM using print level PL."
(let ((cpfs custom-print-functions)
- (ret nil))
+ (ret nil))
(while cpfs
(when (funcall (car cpfs) obj stream pl)
- (setq cpfs nil
- ret t))
+ (setq cpfs nil
+ ret t))
(setq cpfs (cdr cpfs)))
ret))
"Print object OBJ not using custom printers."
(let ((custom-object-printer nil))
(princ obj stream)))
-
+
;; Install custom printer
(setq custom-object-printer 'print-custom-object)
(defmacro pushnew (x place &rest keys)
"(pushnew X PLACE): insert X at the head of the list stored in PLACE.
Like (push X PLACE), except that the list is unmodified if X is `eql'
-to an element already on the list.
+to an element already on the list.
Keywords supported: :test :test-not :key"
(if (symbolp place) (list 'setq place (list* 'adjoin x place keys))
(list* 'callf2 'adjoin x place keys)))
;;; cmdloop.el --- support functions for the top-level command loop.
;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc.
-
+
;; Author: Richard Mlynarik
;; Date: 8-Jul-92
;; Maintainer: SXEmacs Development Team
(display-error error-object t)
(if (noninteractive)
- (progn
+ (progn
(if old-debug-on-error
(progn
(message "Backtrace:\n\n")
(backtrace)
(message "\n")))
- (message "%s exiting\n." emacs-program-name)
- (kill-emacs -1)))
+ (message "%s exiting\n." emacs-program-name)
+ (kill-emacs -1)))
t))
(defun describe-last-error ()
(if (not (noninteractive))
(enqueue-eval-event
#'(lambda (arg)
- (let ((tail (nthcdr 30 command-history)))
- (if tail (setcdr tail nil)))
- (let ((tail (nthcdr 30 values)))
- (if tail (setcdr tail nil))))
+ (let ((tail (nthcdr 30 command-history)))
+ (if tail (setcdr tail nil)))
+ (let ((tail (nthcdr 30 values)))
+ (if tail (setcdr tail nil))))
nil)))
(add-hook 'pre-gc-hook 'truncate-command-history-for-gc)
(put 'file-error 'display-error
#'(lambda (error-object stream)
- (let ((tail (cdr error-object))
- (first t))
- (princ (car tail) stream)
- (while (setq tail (cdr tail))
- (princ (if first ": " ", ") stream)
- (princ (car tail) stream)
- (setq first nil)))))
+ (let ((tail (cdr error-object))
+ (first t))
+ (princ (car tail) stream)
+ (while (setq tail (cdr tail))
+ (princ (if first ": " ", ") stream)
+ (princ (car tail) stream)
+ (setq first nil)))))
(put 'undefined-keystroke-sequence 'display-error
#'(lambda (error-object stream)
- (princ (key-description (car (cdr error-object))) stream)
+ (princ (key-description (car (cdr error-object))) stream)
;; #### I18N3: doesn't localize properly.
- (princ (gettext " not defined.") stream) ; doo dah, doo dah.
- ))
+ (princ (gettext " not defined.") stream) ; doo dah, doo dah.
+ ))
\f
(defcustom teach-extended-commands-p t
;; Note: This doesn't hack "this-command-keys"
(let ((prefix-arg prefix-arg))
(setq this-command (read-command
- ;; Note: this has the hard-wired
- ;; "C-u" and "M-x" string bug in common
- ;; with all GNU Emacs's.
+ ;; Note: this has the hard-wired
+ ;; "C-u" and "M-x" string bug in common
+ ;; with all GNU Emacs's.
;; (i.e. it prints C-u and M-x regardless of
;; whether some other keys were actually bound
- ;; to `execute-extended-command' and
+ ;; to `execute-extended-command' and
;; `universal-argument'.
- (cond ((eq prefix-arg '-)
- "- M-x ")
- ((equal prefix-arg '(4))
- "C-u M-x ")
- ((integerp prefix-arg)
- (format "%d M-x " prefix-arg))
- ((and (consp prefix-arg)
- (integerp (car prefix-arg)))
- (format "%d M-x " (car prefix-arg)))
- (t
- "M-x ")))))
+ (cond ((eq prefix-arg '-)
+ "- M-x ")
+ ((equal prefix-arg '(4))
+ "C-u M-x ")
+ ((integerp prefix-arg)
+ (format "%d M-x " prefix-arg))
+ ((and (consp prefix-arg)
+ (integerp (car prefix-arg)))
+ (format "%d M-x " (car prefix-arg)))
+ (t
+ "M-x ")))))
(if (and teach-extended-commands-p
(interactive-p))
; (get _command 'disabled))
; (run-hooks disabled-command-hook))
; ((or (stringp _cmd) (vectorp _cmd))
-; ;; If requested, place the macro in the command history.
+; ;; If requested, place the macro in the command history.
; ;; For other sorts of commands, call-interactively takes
-; ;; care of this.
+; ;; care of this.
; (if _record-flag
; (setq command-history
; (cons (list 'execute-kbd-macro _cmd _prefix)
Also accepts Space to mean yes, or Delete to mean no."
(save-excursion
(let* ((pre "")
- (yn (gettext "(y or n) "))
+ (yn (gettext "(y or n) "))
;; we need to translate the prompt ourselves because of the
;; strange way we handle it.
(prompt (gettext prompt))
- event)
+ event)
(while (stringp yn)
- (if (let ((cursor-in-echo-area t)
- (inhibit-quit t))
- (message "%s%s%s" pre prompt yn)
- (setq event (next-command-event event))
+ (if (let ((cursor-in-echo-area t)
+ (inhibit-quit t))
+ (message "%s%s%s" pre prompt yn)
+ (setq event (next-command-event event))
(condition-case nil
(prog1
(or quit-flag (eq 'keyboard-quit (key-binding event)))
(setq quit-flag nil))
(wrong-type-argument t)))
- (progn
- (message "%s%s%s%s" pre prompt yn (single-key-description event))
- (setq quit-flag nil)
- (signal 'quit '())))
- (let* ((keys (events-to-keys (vector event)))
+ (progn
+ (message "%s%s%s%s" pre prompt yn (single-key-description event))
+ (setq quit-flag nil)
+ (signal 'quit '())))
+ (let* ((keys (events-to-keys (vector event)))
(def (lookup-key query-replace-map keys)))
- (cond ((eq def 'skip)
- (message "%s%sNo" prompt yn)
+ (cond ((eq def 'skip)
+ (message "%s%sNo" prompt yn)
(setq yn nil))
- ((eq def 'act)
- (message "%s%sYes" prompt yn)
+ ((eq def 'act)
+ (message "%s%sYes" prompt yn)
(setq yn t))
((eq def 'recenter)
(recenter))
((or (eq def 'quit) (eq def 'exit-prefix))
(signal 'quit '()))
- ((button-release-event-p event) ; ignore them
- nil)
- (t
- (message "%s%s%s%s" pre prompt yn
- (single-key-description event))
- (ding nil 'y-or-n-p)
- (discard-input)
- (if (= (length pre) 0)
- (setq pre (gettext "Please answer y or n. ")))))))
+ ((button-release-event-p event) ; ignore them
+ nil)
+ (t
+ (message "%s%s%s%s" pre prompt yn
+ (single-key-description event))
+ (ding nil 'y-or-n-p)
+ (discard-input)
+ (if (= (length pre) 0)
+ (setq pre (gettext "Please answer y or n. ")))))))
yn)))
(defun yes-or-no-p-minibuf (prompt)
and can edit it until it has been confirmed."
(save-excursion
(let ((p (concat (gettext prompt) (gettext "(yes or no) ")))
- (ans ""))
+ (ans ""))
(while (stringp ans)
- (setq ans (downcase (read-string p nil t))) ;no history
- (cond ((string-equal ans (gettext "yes"))
- (setq ans t))
- ((string-equal ans (gettext "no"))
- (setq ans nil))
- (t
- (ding nil 'yes-or-no-p)
- (discard-input)
- (message "Please answer yes or no.")
- (sleep-for 2))))
+ (setq ans (downcase (read-string p nil t))) ;no history
+ (cond ((string-equal ans (gettext "yes"))
+ (setq ans t))
+ ((string-equal ans (gettext "no"))
+ (setq ans nil))
+ (t
+ (ding nil 'yes-or-no-p)
+ (discard-input)
+ (message "Please answer yes or no.")
+ (sleep-for 2))))
ans)))
(defun yes-or-no-p (prompt)
(and (event-matches-key-specifier-p event (quit-char))
(signal 'quit nil)))
(prog1 (or (event-to-character event)
- ;; Kludge. If the event we read was a mouse-release,
- ;; discard it and read the next one.
- (if (button-release-event-p event)
- (event-to-character (next-command-event event)))
- (error "Key read has no ASCII equivalent %S" event))
- ;; this is not necessary, but is marginally more efficient than GC.
- (deallocate-event event)))))
+ ;; Kludge. If the event we read was a mouse-release,
+ ;; discard it and read the next one.
+ (if (button-release-event-p event)
+ (event-to-character (next-command-event event)))
+ (error "Key read has no ASCII equivalent %S" event))
+ ;; this is not necessary, but is marginally more efficient than GC.
+ (deallocate-event event)))))
(defun read-char-exclusive ()
"Read a character from the command input (keyboard or macro).
; (logand 255 code))))
))
-(defun momentary-string-display (string pos &optional exit-char message)
+(defun momentary-string-display (string pos &optional exit-char message)
"Momentarily display STRING in the buffer at POS.
Display remains until next character is typed.
If the char is EXIT-CHAR (optional third arg, default is SPC) it is swallowed;
(setq eol-type (cond ((or (eq eol-type 'unix)
(eq eol-type 'lf))
'eol-lf)
- ((or (eq eol-type 'dos)
+ ((or (eq eol-type 'dos)
(eq eol-type 'crlf))
'eol-crlf)
- ((or (eq eol-type 'mac)
+ ((or (eq eol-type 'mac)
(eq eol-type 'cr))
'eol-cr)
- (t eol-type))))
+ (t eol-type))))
(let ((orig-eol-type (coding-system-eol-type coding-system)))
(if (null orig-eol-type)
- (if (not eol-type)
- coding-system
- (coding-system-property coding-system eol-type))
+ (if (not eol-type)
+ coding-system
+ (coding-system-property coding-system eol-type))
(let ((base (coding-system-base coding-system)))
- (if (not eol-type)
- base
- (if (= eol-type orig-eol-type)
- coding-system
- (setq orig-eol-type (coding-system-eol-type base))
- (if (null orig-eol-type)
- (coding-system-property base eol-type))))))))
+ (if (not eol-type)
+ base
+ (if (= eol-type orig-eol-type)
+ coding-system
+ (setq orig-eol-type (coding-system-eol-type base))
+ (if (null orig-eol-type)
+ (coding-system-property base eol-type))))))))
(defun universal-coding-system-argument ()
(let ((codesys (intern (buffer-substring
(match-beginning 1)(match-end 1)))))
(if (find-coding-system codesys) codesys)))
- ;; (save-excursion
- ;; (let (start end)
- ;; (and (re-search-forward "^;+[ \t]*Local Variables:" nil t)
- ;; (setq start (match-end 0))
- ;; (re-search-forward "\n;+[ \t]*End:")
- ;; (setq end (match-beginning 0))
- ;; (save-restriction
- ;; (narrow-to-region start end)
- ;; (goto-char start)
- ;; (re-search-forward "^;;; coding: \\([^\n]+\\)$" nil t)
- ;; )
- ;; (let ((codesys
- ;; (intern (buffer-substring
- ;; (match-beginning 1)(match-end 1)))))
- ;; (if (find-coding-system codesys) codesys))
- ;; )))
+ ;; (save-excursion
+ ;; (let (start end)
+ ;; (and (re-search-forward "^;+[ \t]*Local Variables:" nil t)
+ ;; (setq start (match-end 0))
+ ;; (re-search-forward "\n;+[ \t]*End:")
+ ;; (setq end (match-beginning 0))
+ ;; (save-restriction
+ ;; (narrow-to-region start end)
+ ;; (goto-char start)
+ ;; (re-search-forward "^;;; coding: \\([^\n]+\\)$" nil t)
+ ;; )
+ ;; (let ((codesys
+ ;; (intern (buffer-substring
+ ;; (match-beginning 1)(match-end 1)))))
+ ;; (if (find-coding-system codesys) codesys))
+ ;; )))
(let ((case-fold-search nil))
(if (search-forward
";;;###coding system: " (+ (point-min) 3000) t)
(handler (find-file-name-handler filename 'load))
(path nil))
(cond (handler
- (funcall handler 'load filename noerror nomessage nosuffix))
- ((<= (length filename) 0)
- (and (null noerror)
- (signal 'file-error (list "Cannot open load file" filename))))
- ((setq path (locate-file filename load-path
- (and (not nosuffix) '(".elc" ".el" ""))))
- ;; now use the internal load to actually load the file.
- (load-internal
- file noerror nomessage nosuffix
- (let ((elc
- ;; use string= instead of string-match to keep match-data.
- (string= ".elc" (downcase (substring path -4)))))
- (or (and (not elc) coding-system-for-read) ; prefer for source file
- ;; find magic-cookie
- (save-excursion
- (set-buffer (get-buffer-create " *load*"))
- (erase-buffer)
- (let ((coding-system-for-read 'raw-text))
- (insert-file-contents path nil 0 3000))
- (find-coding-system-magic-cookie))
- (if elc
- ;; if reading a byte-compiled file and we didn't find
- ;; a coding-system magic cookie, then use `binary'.
- ;; We need to guarantee that we never do autodetection
- ;; on byte-compiled files because confusion here would
- ;; be a very bad thing. Pre-existing byte-compiled
- ;; files are always in the `binary' coding system.
- ;; Also, byte-compiled files always use `lf' to terminate
- ;; a line; don't risk confusion here either.
- 'binary
- (or (find-file-coding-system-for-read-from-filename path)
- ;; looking up in `file-coding-system-alist'.
- ;; otherwise use `buffer-file-coding-system-for-read',
- ;; as normal
- buffer-file-coding-system-for-read)
- )))))
- ((setq path (locate-file filename load-path
- (and (not nosuffix)
+ (funcall handler 'load filename noerror nomessage nosuffix))
+ ((<= (length filename) 0)
+ (and (null noerror)
+ (signal 'file-error (list "Cannot open load file" filename))))
+ ((setq path (locate-file filename load-path
+ (and (not nosuffix) '(".elc" ".el" ""))))
+ ;; now use the internal load to actually load the file.
+ (load-internal
+ file noerror nomessage nosuffix
+ (let ((elc
+ ;; use string= instead of string-match to keep match-data.
+ (string= ".elc" (downcase (substring path -4)))))
+ (or (and (not elc) coding-system-for-read) ; prefer for source file
+ ;; find magic-cookie
+ (save-excursion
+ (set-buffer (get-buffer-create " *load*"))
+ (erase-buffer)
+ (let ((coding-system-for-read 'raw-text))
+ (insert-file-contents path nil 0 3000))
+ (find-coding-system-magic-cookie))
+ (if elc
+ ;; if reading a byte-compiled file and we didn't find
+ ;; a coding-system magic cookie, then use `binary'.
+ ;; We need to guarantee that we never do autodetection
+ ;; on byte-compiled files because confusion here would
+ ;; be a very bad thing. Pre-existing byte-compiled
+ ;; files are always in the `binary' coding system.
+ ;; Also, byte-compiled files always use `lf' to terminate
+ ;; a line; don't risk confusion here either.
+ 'binary
+ (or (find-file-coding-system-for-read-from-filename path)
+ ;; looking up in `file-coding-system-alist'.
+ ;; otherwise use `buffer-file-coding-system-for-read',
+ ;; as normal
+ buffer-file-coding-system-for-read)
+ )))))
+ ((setq path (locate-file filename load-path
+ (and (not nosuffix)
(if (boundp 'module-extensions)
module-extensions))))
- (if (featurep 'modules)
- (let ((load-modules-quietly nomessage))
- (declare-fboundp (load-module path)))
- (signal 'file-error '("This SXEmacs does not support modules"))))
+ (if (featurep 'modules)
+ (let ((load-modules-quietly nomessage))
+ (declare-fboundp (load-module path)))
+ (signal 'file-error '("This SXEmacs does not support modules"))))
((null noerror)
- (signal 'file-error (list "Cannot open load file" filename))))))
+ (signal 'file-error (list "Cannot open load file" filename))))))
(defvar insert-file-contents-access-hook nil
"A hook to make a file accessible before reading it.
`set-process-filter') are stream-oriented. That means UDP datagrams are
not guaranteed to be sent and received in discrete packets. (But small
datagrams around 500 bytes that are not truncated by `process-send-string'
-are usually fine.) Note further that UDP protocol does not guard against
+are usually fine.) Note further that UDP protocol does not guard against
lost packets."
(let (cs-r cs-w)
(let (ret)
(list fun args
(nconc
(list 'list
- (list 'quote
+ (list 'quote
(intern (concat (symbol-name group) "-"
(symbol-name fun)))))
args))
(defun byte-compile-dest-file (filename)
"Convert an Emacs Lisp source file name to a compiled file name."
(let ((outfile (if (string-match lispdir-regexp filename)
- (file-name-sans-extension
- (substring filename (match-end 0)))
- filename)))
+ (file-name-sans-extension
+ (substring filename (match-end 0)))
+ filename)))
(expand-file-name (concat outfile ".elc") destdir)))
(defun parse-command-line (cmdl)
(let ((newcmdl (dllist))
- (cmdlpl (make-skiplist))
- (mm (compile-regexp "^--"))
- (ign (compile-regexp "^-[^-]")))
+ (cmdlpl (make-skiplist))
+ (mm (compile-regexp "^--"))
+ (ign (compile-regexp "^-[^-]")))
(while (car cmdl)
(let* ((file (car cmdl))
- (current (expand-file-name file sourcedir))
- (current (if (file-exists-p current)
- current
- (expand-file-name file destdir))))
- (cond ((string-match mm file)
- (let ((key (intern file))
- (val (car (cdr-safe cmdl))))
- (put-skiplist cmdlpl key val)
- (setq cmdl (cdr-safe cmdl))))
- ((string-match ign file)
- (setq cmdl (cdr-safe cmdl)))
- ((string-match emacs-lisp-file-regexp current)
- (dllist-append newcmdl current))
- (t nil)))
+ (current (expand-file-name file sourcedir))
+ (current (if (file-exists-p current)
+ current
+ (expand-file-name file destdir))))
+ (cond ((string-match mm file)
+ (let ((key (intern file))
+ (val (car (cdr-safe cmdl))))
+ (put-skiplist cmdlpl key val)
+ (setq cmdl (cdr-safe cmdl))))
+ ((string-match ign file)
+ (setq cmdl (cdr-safe cmdl)))
+ ((string-match emacs-lisp-file-regexp current)
+ (dllist-append newcmdl current))
+ (t nil)))
(setq cmdl (cdr-safe cmdl)))
(put newcmdl :tweaks cmdlpl)
newcmdl))
(mapc-internal
#'(lambda (file)
(when (file-newer-than-file-p file (byte-compile-dest-file file))
- (dllist-append files-to-compile file)))
+ (dllist-append files-to-compile file)))
files))
(setq problem-files (dllist))
(mapc-internal
#'(lambda (file)
(condition-case nil
- (byte-compile-file file)
+ (byte-compile-file file)
(error
- (progn
- (dllist-append problem-files file)
- (message "Dinn work: %s" file)))))
+ (progn
+ (dllist-append problem-files file)
+ (message "Dinn work: %s" file)))))
files-to-compile)
;; (mapc-internal
(defun resume-pid-console (pid)
"Resume the consoles with a controlling process of PID."
- (mapc (lambda (c)
+ (mapc (lambda (c)
(if (and (eq (console-type c) 'tty)
(eql pid (console-tty-controlling-process c)))
(resume-console c)))
obarray (lambda (symbol)
(and (boundp symbol)
(or (get symbol 'custom-type)
- (user-variable-p symbol))))
- t nil nil (and v (symbol-name v))))
+ (user-variable-p symbol))))
+ t nil nil (and v (symbol-name v))))
(list (if (equal val "")
(if (symbolp v) v nil)
(intern val)))))
"Set all modified options and save them."
(interactive)
(let ((all-children custom-options)
- children)
+ children)
(mapc (lambda (child)
(when (memq (widget-get child :custom-state) '(modified set))
- (push child children)))
- all-children)
+ (push child children)))
+ all-children)
(let ((the-children children)
- child)
+ child)
(while (setq child (pop the-children))
- (widget-apply child :custom-pre-save)))
+ (widget-apply child :custom-pre-save)))
(custom-save-all)
(let ((the-children children)
- child)
+ child)
(while (setq child (pop the-children))
- (widget-apply child :custom-post-save)))
+ (widget-apply child :custom-post-save)))
))
(defvar custom-reset-menu
"Reset all modified, set, or saved group members to their standard settings."
(interactive)
(let ((all-children custom-options)
- children must-save)
+ children must-save)
(mapc (lambda (child)
(when (memq (widget-get child :custom-state) '(modified set saved))
- (push child children)))
- all-children)
+ (push child children)))
+ all-children)
(let ((the-children children)
- child)
+ child)
(while (setq child (pop the-children))
- (and (widget-apply child :custom-pre-reset-standard)
- (setq must-save t))))
+ (and (widget-apply child :custom-pre-reset-standard)
+ (setq must-save t))))
(and must-save (custom-save-all))
(let ((the-children children)
- child)
+ child)
(while (setq child (pop the-children))
- (widget-apply child :custom-post-reset-standard)))
+ (widget-apply child :custom-post-reset-standard)))
))
\f
(and version
(or (null since-version)
(customize-version-lessp since-version
- version))))
+ version))))
(push (list symbol 'custom-variable) found))))
(unless found
(error "No user options have changed defaults %s"
(return-from custom-load nil)))
#'(lambda ()
(load (expand-file-name "custom-defines" dir))))))
- ;; we get here only from the `return-from'; see above
+ ;; we get here only from the `return-from'; see above
(load source))))
(defun custom-load-widget (widget)
(defvar custom-variable-menu
`(("Set for Current Session" custom-variable-set
,#'(lambda (widget)
- (eq (widget-get widget :custom-state) 'modified)))
+ (eq (widget-get widget :custom-state) 'modified)))
("Save for Future Sessions" custom-variable-save
,#'(lambda (widget)
- (memq (widget-get widget :custom-state)
- '(modified set changed rogue))))
+ (memq (widget-get widget :custom-state)
+ '(modified set changed rogue))))
("Reset to Current" custom-redraw
,#'(lambda (widget)
- (and (default-boundp (widget-value widget))
- (memq (widget-get widget :custom-state) '(modified changed)))))
+ (and (default-boundp (widget-value widget))
+ (memq (widget-get widget :custom-state) '(modified changed)))))
("Reset to Saved" custom-variable-reset-saved
,#'(lambda (widget)
- (and (or (get (widget-value widget) 'saved-value)
- (get (widget-value widget) 'saved-variable-comment))
- (memq (widget-get widget :custom-state)
- '(modified set changed rogue)))))
+ (and (or (get (widget-value widget) 'saved-value)
+ (get (widget-value widget) 'saved-variable-comment))
+ (memq (widget-get widget :custom-state)
+ '(modified set changed rogue)))))
("Reset to Standard Settings" custom-variable-reset-standard
,#'(lambda (widget)
- (and (get (widget-value widget) 'standard-value)
- (memq (widget-get widget :custom-state)
- '(modified set changed saved rogue)))))
+ (and (get (widget-value widget) 'standard-value)
+ (memq (widget-get widget :custom-state)
+ '(modified set changed saved rogue)))))
("---" ignore ignore)
("Add Comment" custom-comment-show custom-comment-invisible-p)
("---" ignore ignore)
("Don't show as Lisp expression" custom-variable-edit
,#'(lambda (widget)
- (eq (widget-get widget :custom-form) 'lisp)))
+ (eq (widget-get widget :custom-form) 'lisp)))
("Show as Lisp expression" custom-variable-edit-lisp
,#'(lambda (widget)
- (eq (widget-get widget :custom-form) 'edit))))
+ (eq (widget-get widget :custom-form) 'edit))))
"Alist of actions for the `custom-variable' widget.
Each entry has the form (NAME ACTION FILTER) where NAME is the name of
the menu entry, ACTION is the function to call on the widget when the
:sample-face 'custom-face-tag-face
:help-echo "Set or reset this face"
:documentation-property #'(lambda (face)
- (face-doc-string face))
+ (face-doc-string face))
:value-create 'custom-face-value-create
:action 'custom-face-action
:custom-category 'face
("Save for Future Sessions" custom-face-save)
("Reset to Saved" custom-face-reset-saved
,#'(lambda (widget)
- (or (get (widget-value widget) 'saved-face)
- (get (widget-value widget) 'saved-face-comment))))
+ (or (get (widget-value widget) 'saved-face)
+ (get (widget-value widget) 'saved-face-comment))))
("Reset to Standard Setting" custom-face-reset-standard
,#'(lambda (widget)
- (get (widget-value widget) 'face-defface-spec)))
+ (get (widget-value widget) 'face-defface-spec)))
("---" ignore ignore)
("Add Comment" custom-comment-show custom-comment-invisible-p)
("---" ignore ignore)
("Show all display specs" custom-face-edit-all
,#'(lambda (widget)
- (not (eq (widget-get widget :custom-form) 'all))))
+ (not (eq (widget-get widget :custom-form) 'all))))
("Just current attributes" custom-face-edit-selected
,#'(lambda (widget)
- (not (eq (widget-get widget :custom-form) 'selected))))
+ (not (eq (widget-get widget :custom-form) 'selected))))
("Show as Lisp expression" custom-face-edit-lisp
,#'(lambda (widget)
- (not (eq (widget-get widget :custom-form) 'lisp)))))
+ (not (eq (widget-get widget :custom-form) 'lisp)))))
"Alist of actions for the `custom-face' widget.
Each entry has the form (NAME ACTION FILTER) where NAME is the name of
the menu entry, ACTION is the function to call on the widget when the
(defun custom-face-post-reset-standard (widget)
"Finish restoring the face edited by WIDGET to its standard settings."
(let* ((symbol (widget-value widget))
- (child (car (widget-get widget :children)))
- (value (get symbol 'face-defface-spec))
- (comment-widget (widget-get widget :comment-widget)))
+ (child (car (widget-get widget :children)))
+ (value (get symbol 'face-defface-spec))
+ (comment-widget (widget-get widget :comment-widget)))
(face-spec-set symbol value nil '(custom))
(put symbol 'face-comment nil)
(widget-value-set child value)
(defvar custom-group-menu
`(("Set for Current Session" custom-group-set
,#'(lambda (widget)
- (eq (widget-get widget :custom-state) 'modified)))
+ (eq (widget-get widget :custom-state) 'modified)))
("Save for Future Sessions" custom-group-save
,#'(lambda (widget)
- (memq (widget-get widget :custom-state) '(modified set))))
+ (memq (widget-get widget :custom-state) '(modified set))))
("Reset to Current" custom-group-reset-current
,#'(lambda (widget)
- (memq (widget-get widget :custom-state) '(modified))))
+ (memq (widget-get widget :custom-state) '(modified))))
("Reset to Saved" custom-group-reset-saved
,#'(lambda (widget)
- (memq (widget-get widget :custom-state) '(modified set))))
+ (memq (widget-get widget :custom-state) '(modified set))))
("Reset to standard setting" custom-group-reset-standard
,#'(lambda (widget)
- (memq (widget-get widget :custom-state) '(modified set saved)))))
+ (memq (widget-get widget :custom-state) '(modified set saved)))))
"Alist of actions for the `custom-group' widget.
Each entry has the form (NAME ACTION FILTER) where NAME is the name of
the menu entry, ACTION is the function to call on the widget when the
"Prepare for saving all modified group members."
(let ((children (widget-get widget :children)))
(mapc (lambda (child)
- (when (memq (widget-get child :custom-state) '(modified set))
- (widget-apply child :custom-pre-save)))
- children)))
+ (when (memq (widget-get child :custom-state) '(modified set))
+ (widget-apply child :custom-pre-save)))
+ children)))
(defun custom-group-post-save (widget)
"Save all modified group members."
(defun custom-group-pre-reset-standard (widget)
"Prepare for resetting all modified, set, or saved group members."
(let ((children (widget-get widget :children))
- must-save)
+ must-save)
(mapc (lambda (child)
- (when (memq (widget-get child :custom-state)
- '(modified set saved))
- (and (widget-apply child :custom-pre-reset-standard)
- (setq must-save t))))
- children)
+ (when (memq (widget-get child :custom-state)
+ '(modified set saved))
+ (and (widget-apply child :custom-pre-reset-standard)
+ (setq must-save t))))
+ children)
must-save
))
(goto-char (point-min))
(condition-case nil
(while (not (eobp))
- (let ((sexp (read (current-buffer))))
- (when (and (listp sexp)
- (memq (car sexp) symbols))
- (delete-region (save-excursion
- (backward-sexp)
- (point))
- (point))
- (while (and (eolp) (not (eobp)))
- (delete-region (point) (prog2 (forward-line 1) (point))))
- )))
+ (let ((sexp (read (current-buffer))))
+ (when (and (listp sexp)
+ (memq (car sexp) symbols))
+ (delete-region (save-excursion
+ (backward-sexp)
+ (point))
+ (point))
+ (while (and (eolp) (not (eobp)))
+ (delete-region (point) (prog2 (forward-line 1) (point))))
+ )))
(end-of-file nil)))
(defsubst custom-save-variable-p (symbol)
"Return non-nil if symbol SYMBOL is a customized variable."
(and (symbolp symbol)
(let ((spec (car-safe (get symbol 'theme-value))))
- (or (and spec (eq (car spec) 'user)
- (eq (second spec) 'set))
- (get symbol 'saved-variable-comment)
- ;; support non-themed vars
- (and (null spec) (get symbol 'saved-value))))))
+ (or (and spec (eq (car spec) 'user)
+ (eq (second spec) 'set))
+ (get symbol 'saved-variable-comment)
+ ;; support non-themed vars
+ (and (null spec) (get symbol 'saved-value))))))
(defun custom-save-variable-internal (symbol)
"Print variable SYMBOL to the standard output.
SYMBOL must be a customized variable."
(let ((requests (get symbol 'custom-requests))
- (now (not (or (get symbol 'standard-value)
- (and (not (boundp symbol))
- (not (eq (get symbol 'force-value)
- 'rogue))))))
- (comment (get symbol 'saved-variable-comment))
- ;; Print everything, no placeholders `...'
- (print-level nil)
- (print-length nil))
+ (now (not (or (get symbol 'standard-value)
+ (and (not (boundp symbol))
+ (not (eq (get symbol 'force-value)
+ 'rogue))))))
+ (comment (get symbol 'saved-variable-comment))
+ ;; Print everything, no placeholders `...'
+ (print-level nil)
+ (print-length nil))
(unless (custom-save-variable-p symbol)
(error 'wrong-type-argument "Not a customized variable" symbol))
(princ "\n '(")
;; (prin1 (third spec))
;; XEmacs -- pretty-print value if available
(if (and custom-save-pretty-print
- (fboundp 'pp))
- ;; To suppress bytecompiler warning
- (with-fboundp 'pp
- (pp (car (get symbol 'saved-value))))
+ (fboundp 'pp))
+ ;; To suppress bytecompiler warning
+ (with-fboundp 'pp
+ (pp (car (get symbol 'saved-value))))
(prin1 (car (get symbol 'saved-value))))
(when (or now requests comment)
(princ (if now " t" " nil")))
(custom-save-loaded-themes)
(custom-save-resets 'theme-value 'custom-reset-variables nil)
(let ((standard-output (current-buffer))
- (sorted-list ()))
+ (sorted-list ()))
;; First create a sorted list of saved variables.
(mapatoms
- (lambda (symbol)
- (when (custom-save-variable-p symbol)
- (push symbol sorted-list))))
+ (lambda (symbol)
+ (when (custom-save-variable-p symbol)
+ (push symbol sorted-list))))
(setq sorted-list (sort sorted-list 'string<))
(unless (bolp)
(princ "\n"))
(princ "(custom-set-variables")
(mapc 'custom-save-variable-internal
- sorted-list)
+ sorted-list)
(princ ")")
(unless (looking-at "\n")
(princ "\n")))))
(let ((theme-spec (car-safe (get symbol 'theme-face)))
(comment (get symbol 'saved-face-comment)))
(or (and (not (memq symbol custom-save-face-ignoring))
- ;; Don't print default face here.
- (or (and theme-spec
- (eq (car theme-spec) 'user)
- (eq (second theme-spec) 'set))
- ;; cope with non-themed faces
- (and (null theme-spec)
- (get symbol 'saved-face))))
- comment)))
+ ;; Don't print default face here.
+ (or (and theme-spec
+ (eq (car theme-spec) 'user)
+ (eq (second theme-spec) 'set))
+ ;; cope with non-themed faces
+ (and (null theme-spec)
+ (get symbol 'saved-face))))
+ comment)))
(defun custom-save-face-internal (symbol)
"Print face SYMBOL to the standard output.
(now (not (or (get symbol 'face-defface-spec)
(and (not (find-face symbol))
(not (eq (get symbol 'force-face) 'rogue))))))
- ;; Print everything, no placeholders `...'
- (print-level nil)
- (print-length nil))
+ ;; Print everything, no placeholders `...'
+ (print-level nil)
+ (print-length nil))
(if (memq symbol custom-save-face-ignoring)
- ;; Do nothing
- nil
+ ;; Do nothing
+ nil
;; Print face
(unless (custom-save-face-p symbol)
- (error 'wrong-type-argument "Not a customized face" symbol))
+ (error 'wrong-type-argument "Not a customized face" symbol))
(princ "\n '(")
(prin1 symbol)
(princ " ")
;; 'custom-set-faces)
(custom-save-resets 'theme-face 'custom-reset-faces '(default))
(let ((standard-output (current-buffer))
- (sorted-list ()))
+ (sorted-list ()))
;; Create a sorted list of faces
(mapatoms
(lambda (symbol)
- (when (custom-save-face-p symbol)
- (push symbol sorted-list))))
+ (when (custom-save-face-p symbol)
+ (push symbol sorted-list))))
(setq sorted-list (sort sorted-list 'string<))
(unless (bolp)
(princ "\n"))
(princ "(custom-set-faces")
;; The default face must be first, since it affects the others.
(when (custom-save-face-p 'default)
- (custom-save-face-internal 'default))
+ (custom-save-face-internal 'default))
(let ((custom-save-face-ignoring '(default)))
(mapc 'custom-save-face-internal
- sorted-list))
+ sorted-list))
(princ ")")
(unless (looking-at "\n")
(princ "\n")))))
"Create a mapper for `custom-save-resets'."
`(lambda (object)
(let ((spec (car-safe (get object (quote ,property))))
- (print-level nil)
- (print-length nil))
+ (print-level nil)
+ (print-length nil))
(with-boundp '(ignored-special started-writing)
- (when (and (not (memq object ignored-special))
- (eq (car spec) 'user)
- (eq (second spec) 'reset))
- ;; Do not write reset statements unless necessary.
- (unless started-writing
- (setq started-writing t)
- (unless (bolp)
- (princ "\n"))
- (princ "(")
- (princ (quote ,setter))
- (princ "\n '(")
- (prin1 object)
- (princ " ")
- (prin1 (third spec))
- (princ ")")))))))
+ (when (and (not (memq object ignored-special))
+ (eq (car spec) 'user)
+ (eq (second spec) 'reset))
+ ;; Do not write reset statements unless necessary.
+ (unless started-writing
+ (setq started-writing t)
+ (unless (bolp)
+ (princ "\n"))
+ (princ "(")
+ (princ (quote ,setter))
+ (princ "\n '(")
+ (prin1 object)
+ (princ " ")
+ (prin1 (third spec))
+ (princ ")")))))))
(defconst custom-save-resets-mapper-alist
(eval-when-compile
(list (list 'theme-value 'custom-reset-variables
- (byte-compile
- (make-custom-save-resets-mapper
- 'theme-value 'custom-reset-variables)))
- (list 'theme-face 'custom-reset-faces
- (byte-compile
- (make-custom-save-resets-mapper
- 'theme-face 'custom-reset-faces)))))
+ (byte-compile
+ (make-custom-save-resets-mapper
+ 'theme-value 'custom-reset-variables)))
+ (list 'theme-face 'custom-reset-faces
+ (byte-compile
+ (make-custom-save-resets-mapper
+ 'theme-face 'custom-reset-faces)))))
"Never use it.
Hashes several heavily used functions for `custom-save-resets'")
;; (custom-save-delete setter) Done by caller
(let ((standard-output (current-buffer))
(mapper (let ((triple (assq property custom-save-resets-mapper-alist)))
- (if (and triple (eq (second triple) setter))
- (third triple)
- (make-custom-save-resets-mapper property setter)))))
+ (if (and triple (eq (second triple) setter))
+ (third triple)
+ (make-custom-save-resets-mapper property setter)))))
(mapc mapper special)
(setq ignored-special special)
(mapatoms mapper)
(defun custom-save-loaded-themes ()
(let ((themes (reverse (get 'user 'theme-loads-themes)))
(standard-output (current-buffer))
- (print-level nil)
- (print-length nil))
+ (print-level nil)
+ (print-length nil))
(when themes
(unless (bolp) (princ "\n"))
(princ "(custom-load-themes")
Invoke button under point. \\[widget-button-press]
Set all modifications. \\[Custom-set]
Make all modifications default. \\[Custom-save]
-Reset all modified options. \\[Custom-reset-current]
+Reset all modified options. \\[Custom-reset-current]
Reset all modified or set options. \\[Custom-reset-saved]
Reset all options. \\[Custom-reset-standard]
; ;; filter to make value suitable for customize
; (lambda (real-value)
; (cond ((or (null real-value) (eq real-value 'unspecified))
-; nil)
-; ((symbolp real-value)
-; (list real-value))
-; (t
-; real-value)))
+; nil)
+; ((symbolp real-value)
+; (list real-value))
+; (t
+; real-value)))
; ;; filter to make customized-value suitable for storing
; (lambda (cus-value)
; (if (and (consp cus-value) (null (cdr cus-value)))
-; (car cus-value)
-; cus-value))
+; (car cus-value)
+; cus-value))
custom-set-face-inherit custom-face-inherit))
"Alist of face attributes.
(max-specpdl-size limits integer)
(meta-prefix-char keyboard character)
(parse-sexp-ignore-comments editing-basics boolean)
- (selective-display display
+ (selective-display display
(choice (const :tag "off" nil)
(integer :tag "space"
:format "%v"
;; If variables are removed from C code, give an error here!
(message "Intrinsic `%S' not bound" symbol))
;; This is called before any user can have changed the value.
- (put symbol 'standard-value
+ (put symbol 'standard-value
(list (quote-maybe (default-value symbol))))
;; Add it to the right group.
(custom-add-to-group group symbol 'custom-variable)
(unless (default-boundp symbol)
;; Use the saved value if it exists, otherwise the standard setting.
(set-default symbol (if (get symbol 'saved-value)
- (eval (car (get symbol 'saved-value)))
- (eval value)))))
+ (eval (car (get symbol 'saved-value)))
+ (eval value)))))
(defun custom-initialize-set (symbol value)
"Initialize SYMBOL with VALUE.
`:set' to initialize SYMBOL."
(unless (default-boundp symbol)
(funcall (or (get symbol 'custom-set) 'set-default)
- symbol
- (if (get symbol 'saved-value)
- (eval (car (get symbol 'saved-value)))
- (eval value)))))
+ symbol
+ (if (get symbol 'saved-value)
+ (eval (car (get symbol 'saved-value)))
+ (eval value)))))
(defun custom-initialize-reset (symbol value)
"Initialize SYMBOL with VALUE.
Like `custom-initialize-set', but use the function specified by
`:get' to reinitialize SYMBOL if it is already bound."
(funcall (or (get symbol 'custom-set) 'set-default)
- symbol
- (cond ((default-boundp symbol)
- (funcall (or (get symbol 'custom-get) 'default-value)
- symbol))
- ((get symbol 'saved-value)
- (eval (car (get symbol 'saved-value))))
- (t
- (eval value)))))
+ symbol
+ (cond ((default-boundp symbol)
+ (funcall (or (get symbol 'custom-get) 'default-value)
+ symbol))
+ ((get symbol 'saved-value)
+ (eval (car (get symbol 'saved-value))))
+ (t
+ (eval value)))))
;; XEmacs change; move to defsubst, since this is only called in one place
;; and usage of it clusters.
not using the standard setting.
For the standard setting, use `set-default'."
(cond ((default-boundp symbol)
- (funcall (or (get symbol 'custom-set) 'set-default)
- symbol
- (funcall (or (get symbol 'custom-get) 'default-value)
- symbol)))
- ((get symbol 'saved-value)
- (funcall (or (get symbol 'custom-set) 'set-default)
- symbol
- (eval (car (get symbol 'saved-value)))))
- (t
- (set-default symbol (eval value)))))
+ (funcall (or (get symbol 'custom-set) 'set-default)
+ symbol
+ (funcall (or (get symbol 'custom-get) 'default-value)
+ symbol)))
+ ((get symbol 'saved-value)
+ (funcall (or (get symbol 'custom-set) 'set-default)
+ symbol
+ (eval (car (get symbol 'saved-value)))))
+ (t
+ (set-default symbol (eval value)))))
(defun custom-declare-variable (symbol default doc &rest args)
"Like `defcustom', but SYMBOL and DEFAULT are evaluated as normal arguments.
(while args
(let ((arg (car args)))
(setq args (cdr args))
- (check-argument-type 'keywordp arg)
- (let ((keyword arg)
- (value (car args)))
- (unless args
- (signal 'error (list "Keyword is missing an argument" keyword)))
+ (check-argument-type 'keywordp arg)
+ (let ((keyword arg)
+ (value (car args)))
+ (unless args
+ (signal 'error (list "Keyword is missing an argument" keyword)))
(setq args (cdr args))
(cond ((eq keyword :initialize)
(setq initialize value))
value)
;; Fast code for the common case.
(put symbol 'custom-options (copy-sequence value))))
- ;; In the event that the byte compile has compiled the init
- ;; value, we want the value the UI sees to be uncompiled.
- ((eq keyword :default)
- (put symbol 'standard-value (list value)))
+ ;; In the event that the byte compile has compiled the init
+ ;; value, we want the value the UI sees to be uncompiled.
+ ((eq keyword :default)
+ (put symbol 'standard-value (list value)))
(t
(custom-handle-keyword symbol keyword value
'custom-variable))))))
The following keywords are meaningful:
:type VALUE should be a widget type for editing the symbol's value.
- The default is `sexp'.
+ The default is `sexp'.
:options VALUE should be a list of valid members of the widget type.
:group VALUE should be a customization group.
- Add SYMBOL to that group.
+ Add SYMBOL to that group.
:link LINK-DATA
- Include an external link after the documentation string for this
- item. This is a sentence containing an active field which
- references some other documentation.
+ Include an external link after the documentation string for this
+ item. This is a sentence containing an active field which
+ references some other documentation.
- There are three alternatives you can use for LINK-DATA:
+ There are three alternatives you can use for LINK-DATA:
- (custom-manual INFO-NODE)
- Link to an Info node; INFO-NODE is a string which specifies
- the node name, as in \"(emacs)Top\". The link appears as
- `[manual]' in the customization buffer.
+ (custom-manual INFO-NODE)
+ Link to an Info node; INFO-NODE is a string which specifies
+ the node name, as in \"(emacs)Top\". The link appears as
+ `[manual]' in the customization buffer.
- (info-link INFO-NODE)
- Like `custom-manual' except that the link appears in the
- customization buffer with the Info node name.
+ (info-link INFO-NODE)
+ Like `custom-manual' except that the link appears in the
+ customization buffer with the Info node name.
- (url-link URL)
- Link to a web page; URL is a string which specifies the URL.
- The link appears in the customization buffer as URL.
+ (url-link URL)
+ Link to a web page; URL is a string which specifies the URL.
+ The link appears in the customization buffer as URL.
- You can specify the text to use in the customization buffer by
- adding `:tag NAME' after the first element of the LINK-DATA; for
- example, (info-link :tag \"foo\" \"(emacs)Top\") makes a link to the
- Emacs manual which appears in the buffer as `foo'.
+ You can specify the text to use in the customization buffer by
+ adding `:tag NAME' after the first element of the LINK-DATA; for
+ example, (info-link :tag \"foo\" \"(emacs)Top\") makes a link to the
+ Emacs manual which appears in the buffer as `foo'.
- An item can have more than one external link; however, most items
- have none at all.
+ An item can have more than one external link; however, most items
+ have none at all.
:initialize
VALUE should be a function used to initialize the
variable. It takes two arguments, the symbol and value
The function takes one argument, a symbol, and should return
the current value for that symbol. The default choice of function
is `custom-default-value'. #### XEmacs used to say `default-value';
- is that right?
+ is that right?
:require
VALUE should be a feature symbol. If you save a value
for this option, then when your custom init file loads the value,
it does (require VALUE) first.
:version
- VALUE should be a string specifying that the variable was
- first introduced, or its default value was changed, in Emacs
- version VERSION.
+ VALUE should be a string specifying that the variable was
+ first introduced, or its default value was changed, in Emacs
+ version VERSION.
:tag LABEL
- Use LABEL, a string, instead of the item's name, to label the item
- in customization menus and buffers.
+ Use LABEL, a string, instead of the item's name, to label the item
+ in customization menus and buffers.
:load FILE
- Load file FILE (a string) before displaying this customization
- item. Loading is done with `load', and only if the file is
- not already loaded.
+ Load file FILE (a string) before displaying this customization
+ item. Loading is done with `load', and only if the file is
+ not already loaded.
:set-after VARIABLES
Specifies that SYMBOL should be set after the list of variables
- VARIABLES when both have been customized.
+ VARIABLES when both have been customized.
Read the section about customization in the Emacs Lisp manual for more
information."
The following KEYWORDs are defined:
:group VALUE should be a customization group.
- Add FACE to that group.
+ Add FACE to that group.
SPEC should be an alist of the form ((DISPLAY ATTS)...).
(setq args (cdr args))
(check-argument-type 'keywordp arg)
(let ((keyword arg)
- (value (car args)))
- (unless args
- (signal 'error (list "Keyword is missing an argument" keyword)))
+ (value (car args)))
+ (unless args
+ (signal 'error (list "Keyword is missing an argument" keyword)))
(setq args (cdr args))
(cond ((eq keyword :prefix)
(put symbol 'custom-prefix value))
The following KEYWORDs are defined:
:group VALUE should be a customization group.
- Add SYMBOL to that group.
+ Add SYMBOL to that group.
Read the section about customization in the Emacs Lisp manual for more
information."
(setq args (cdr args))
(check-argument-type 'keywordp arg)
(let ((keyword arg)
- (value (car args)))
- (unless args
- (signal 'error (list "Keyword is missing an argument" keyword)))
- (setq args (cdr args))
- (custom-handle-keyword symbol keyword value type)))))
+ (value (car args)))
+ (unless args
+ (signal 'error (list "Keyword is missing an argument" keyword)))
+ (setq args (cdr args))
+ (custom-handle-keyword symbol keyword value type)))))
(defun custom-handle-keyword (symbol keyword value type)
"For customization option SYMBOL, handle KEYWORD with VALUE.
(custom-add-load symbol value))
((eq keyword :tag)
(put symbol 'custom-tag value))
- ((eq keyword :set-after)
+ ((eq keyword :set-after)
(custom-add-dependencies symbol value))
(t
(signal 'error (list "Unknown keyword" keyword)))))
(check-argument-type 'keywordp arg)
(let ((keyword arg)
(value (car args)))
- (unless args
- (signal 'error (list "Keyword is missing an argument" keyword)))
+ (unless args
+ (signal 'error (list "Keyword is missing an argument" keyword)))
(setq args (cdr args))
(cond ((eq keyword :short-description)
(put theme 'theme-short-description value))
ARGS may also contain boolean :toggle-only, whose non-nil value
means that only toggle command will be defined."
(let ((msg (plist-get args :message))
- (toggle-fun (or (get var 'toggle-function)
- (intern (format "toggle-%S" var))))
- (turn-on-fun (or (get var 'turn-on-function)
- (intern (format "turn-on-%S" var))))
- (turn-off-fun (or (get var 'turn-off-function)
- (intern (format "turn-off-%S" var))))
- (toggle-only (plist-get args :toggle-only)))
+ (toggle-fun (or (get var 'toggle-function)
+ (intern (format "toggle-%S" var))))
+ (turn-on-fun (or (get var 'turn-on-function)
+ (intern (format "turn-on-%S" var))))
+ (turn-off-fun (or (get var 'turn-off-function)
+ (intern (format "turn-off-%S" var))))
+ (toggle-only (plist-get args :toggle-only)))
(mapc (lambda (p)
- (setq args (plist-remprop args p)))
- '(:message :toggle-only))
+ (setq args (plist-remprop args p)))
+ '(:message :toggle-only))
`(progn
(defcustom ,var ,value ,doc
- :type 'boolean ,@args)
+ :type 'boolean ,@args)
(put ',var 'toggle-variable t)
(defun ,toggle-fun (arg)
- ,(format "Toggle `%s' on or off." var)
- (interactive "_P")
- (customize-set-variable
- ',var (if (null arg)
- (not ,var)
- (> (prefix-numeric-value arg) 0)))
- ,(when msg
- `(message "%S is %s" ',var (if ,var "ON" "OFF"))))
+ ,(format "Toggle `%s' on or off." var)
+ (interactive "_P")
+ (customize-set-variable
+ ',var (if (null arg)
+ (not ,var)
+ (> (prefix-numeric-value arg) 0)))
+ ,(when msg
+ `(message "%S is %s" ',var (if ,var "ON" "OFF"))))
(unless ,toggle-only
- (defun ,turn-on-fun ()
- ,(format "Turn on `%s'." var)
- (interactive)
- (,toggle-fun 1))
- (defun ,turn-off-fun ()
- ,(format "Turn off `%s'." var)
- (interactive)
- (,toggle-fun -1))))))
+ (defun ,turn-on-fun ()
+ ,(format "Turn on `%s'." var)
+ (interactive)
+ (,toggle-fun 1))
+ (defun ,turn-off-fun ()
+ ,(format "Turn off `%s'." var)
+ (interactive)
+ (,toggle-fun -1))))))
;;; Initializing.
See `custom-known-themes' for a list of known themes."
(let ((old (get symbol prop)))
(if (eq (car-safe (car-safe old)) theme)
- (setq old (cdr old)))
+ (setq old (cdr old)))
(put symbol prop (cons (list theme mode value) old))))
(defvar custom-local-buffer nil
(now (nth 2 entry))
(requests (nth 3 entry))
(comment (nth 4 entry))
- set)
+ set)
(when requests
(put symbol 'custom-requests requests)
(mapc 'require requests))
(setq set (or (get symbol 'custom-set) 'custom-set-default))
(put symbol 'saved-value (list value))
(put symbol 'saved-variable-comment comment)
- (custom-push-theme 'theme-value symbol theme 'set value)
+ (custom-push-theme 'theme-value symbol theme 'set value)
;; Allow for errors in the case where the setter has
;; changed between versions, say, but let the user know.
(condition-case data
(let ((symbol (nth 0 args))
(value (nth 1 args)))
(put symbol 'saved-value (list value))
- (custom-push-theme 'theme-value symbol theme 'set value))
+ (custom-push-theme 'theme-value symbol theme 'set value))
(setq args (cdr (cdr args))))))))
(defun custom-set-default (variable value)
(stringp sexp)
(numberp sexp)
(vectorp sexp)
-;;; (and (fboundp 'characterp)
-;;; (characterp sexp))
+;;; (and (fboundp 'characterp)
+;;; (characterp sexp))
)
sexp
(list 'quote sexp)))
(mapatoms (lambda (symbol)
;; This works even if symbol is both a variable and a
;; face.
- (setq spec-list (get symbol 'theme-value))
- (when spec-list
- (put symbol 'theme-value (custom-remove-theme spec-list theme))
- (custom-theme-reset-internal symbol 'user))
- (setq spec-list (get symbol 'theme-face))
- (when spec-list
- (put symbol 'theme-face (custom-remove-theme spec-list theme))
- (custom-theme-reset-internal-face symbol 'user))))))
+ (setq spec-list (get symbol 'theme-value))
+ (when spec-list
+ (put symbol 'theme-value (custom-remove-theme spec-list theme))
+ (custom-theme-reset-internal symbol 'user))
+ (setq spec-list (get symbol 'theme-face))
+ (when spec-list
+ (put symbol 'theme-face (custom-remove-theme spec-list theme))
+ (custom-theme-reset-internal-face symbol 'user))))))
(defun custom-theme-load-themes (by-theme &rest body)
"Load the themes specified by BODY.
;; it might have gone away without the user knowing.
(let ((value (cdr (assoc theme theme-spec-list))))
(if value
- (if (eq (car value) 'set)
- (cdr value)
- (custom-theme-value (cadr value) theme-spec-list)))))
+ (if (eq (car value) 'set)
+ (cdr value)
+ (custom-theme-value (cadr value) theme-spec-list)))))
(defun custom-theme-variable-value (variable theme)
value. See `custom-theme-variable-value'. The standard value is
stored in SYMBOL's property `standard-value'."
(let ((value (custom-theme-variable-value symbol to-theme))
- was-in-theme)
+ was-in-theme)
(setq was-in-theme value)
(setq value (or value (get symbol 'standard-value)))
(when value
(put symbol 'saved-value was-in-theme)
(if (or (get 'force-value symbol) (default-boundp symbol))
- (funcall (or (get symbol 'custom-set) 'set-default) symbol
- (eval (car value)))))
+ (funcall (or (get symbol 'custom-set) 'set-default) symbol
+ (eval (car value)))))
value))
This means reset VARIABLE to its value in TO-THEME."
(custom-check-theme theme)
(mapcar #'(lambda (arg)
- (apply #'custom-theme-reset-internal arg)
- (custom-push-theme 'theme-value (car arg) theme 'reset (cadr arg)))
+ (apply #'custom-theme-reset-internal arg)
+ (custom-push-theme 'theme-value (car arg) theme 'reset (cadr arg)))
args))
(defun custom-reset-variables (&rest args)
CHILD: the name of the command for the derived mode.
PARENT: the name of the command for the parent mode (e.g. `text-mode')
- or nil if there is no parent.
+ or nil if there is no parent.
NAME: a string which will appear in the status line (e.g. \"Hypertext\")
DOCSTRING: an optional documentation string--if you do not supply one,
- the function will attempt to invent something useful.
+ the function will attempt to invent something useful.
BODY: forms to execute just before running the
- hooks for the new mode. Do not use `interactive' here.
+ hooks for the new mode. Do not use `interactive' here.
BODY can start with a bunch of keyword arguments. The following keyword
arguments are currently understood:
", as the final step\nduring initialization.")))
(unless (or (string-match (regexp-quote "\\{") docstring)
- (string-match (regexp-quote "\\[") docstring))
+ (string-match (regexp-quote "\\[") docstring))
;; And don't forget to put the mode's keymap.
(setq docstring (concat docstring "\n\n\\{" (symbol-name map) "}")))
If CONTROLLING-PROCESS is non-nil, it should be an integer
specifying the process id of the process in control of the specified tty. If
it is nil, it is assumes to be the value returned by emacs-pid."
- (make-device 'tty tty (list 'terminal-type terminal-type
+ (make-device 'tty tty (list 'terminal-type terminal-type
'controlling-process controlling-process)))
(defun device-pixel-width (&optional device)
If DEVICE is not provided then the selected device is used."
(or device (setq device (selected-device)))
(or (symbolp name) (error "function name must be a symbol"))
- (let ((devmeth (intern (concat (symbol-name
+ (let ((devmeth (intern (concat (symbol-name
(device-type device)) "-" (symbol-name name)))))
(if (functionp devmeth)
(if args
're-search-backward
'search-backward))
(glyph-image-property
- (car (glyph-image-property
+ (car (glyph-image-property
(nth 1 (glyph-image-property
search-dialog :items domain))
:items domain)) :text domain))
"Popup a search dialog box."
(interactive)
(let ((parent (selected-frame)))
- (make-dialog-box
+ (make-dialog-box
'general
:parent parent
:title "Search"
:spec
(setq search-dialog
(make-glyph
- `[layout
- :orientation horizontal
- :vertically-justify top
- :horizontally-justify center
+ `[layout
+ :orientation horizontal
+ :vertically-justify top
+ :horizontally-justify center
:border [string :data "Search"]
- :items
- ([layout :orientation vertical
+ :items
+ ([layout :orientation vertical
:justify top ; implies left also
- :items
+ :items
([string :data "Search for:"]
[button :descriptor "Match Case"
:style toggle
:callback-ex
(lambda (image-instance event)
(isearch-dehighlight)
- (delete-frame
+ (delete-frame
(event-channel event)))])])]))
;; These are no longer strictly necessary, but not setting a size
;; at all yields a much more noticeable resize since the initial
[ \"name\" callback <active-p> ]
[ \"name\" callback <active-p> \"suffix\" ]
[ \"name\" callback :<keyword> <value> :<keyword> <value> ... ]
-
+
The name is the string to display on the button; it is filtered through the
resource database, so it is possible for resources to override what string
is actually displayed.
-
+
Accelerators can be indicated in the string by putting the sequence
\"%_\" before the character corresponding to the key that will invoke
the button. Uppercase and lowercase accelerators are equivalent. The
sequence \"%%\" is also special, and is translated into a single %.
-
+
If the `callback' of a button is a symbol, then it must name a command.
It will be invoked with `call-interactively'. If it is a list, then it is
evaluated with `eval'.
-
+
One (and only one) of the buttons may be `nil'. This marker means that all
following buttons should be flushright instead of flushleft.
-
+
Though the keyword/value syntax is supported for dialog boxes just as in
popup menus, the only keyword which is both meaningful and fully implemented
for dialog box buttons is `:active'.
a device is specified, then changes are stored into the settings object
currently selected into that printer. If a settings object is supplied,
then changes are recorded into it, and, it is selected into a
-printer, then changes are propagated to that printer
+printer, then changes are propagated to that printer
too.
Return value is nil if the user has canceled the dialog. Otherwise, it
is a new plist, with the following properties:
name Printer device name, even if unchanged by the user.
from-page First page to print, 1-based. Returned if
- `selected-page-button' is `pages'.
- user, then this value is not included in the plist.
+ `selected-page-button' is `pages'.
+ user, then this value is not included in the plist.
to-page Last page to print, inclusive, 1-based. Returned if
- `selected-page-button' is `pages'.
+ `selected-page-button' is `pages'.
copies Number of copies to print. Always returned.
selected-page-button Which page button was selected (`all', `selection',
- or `pages').
+ or `pages').
The DEVICE is destroyed and an error is signaled in case of
initialization problem with the new printer.
(set-face-background 'modeline [default background] frame)
;; resize before mapping
(when cl-autosize
- (set-frame-pixel-size
+ (set-frame-pixel-size
frame
- (image-instance-width
- (glyph-image-instance cl-spec
+ (image-instance-width
+ (glyph-image-instance cl-spec
(frame-selected-window frame)))
- (image-instance-height
- (glyph-image-instance cl-spec
+ (image-instance-height
+ (glyph-image-instance cl-spec
(frame-selected-window frame)))))
;; somehow, even though the resizing is supposed
;; to be while the frame is not visible, a
(setq macro t
obj (cdr obj)))
(if (and (listp obj) (eq (car obj) 'byte-code))
- (setq obj (list 'lambda nil obj)))
+ (setq obj (list 'lambda nil obj)))
(if (and (listp obj) (not (eq (car obj) 'lambda)))
(error "not a function"))
(if (consp obj)
(let ((interactive (if (consp obj)
(elt (assq 'interactive obj) 1)
(elt (compiled-function-interactive obj) 1))))
- (if (eq (car-safe (car-safe obj)) 'interactive)
- (setq obj (cdr obj)))
- (indent-to indent)
- (insert " interactive: ")
+ (if (eq (car-safe (car-safe obj)) 'interactive)
+ (setq obj (cdr obj)))
+ (indent-to indent)
+ (insert " interactive: ")
(if (eq (car-safe interactive) 'byte-code)
(progn
(insert "\n")
(princ "\nCharacter display glyph sequences:\n")
(save-excursion
(let ((vector (make-vector 256 nil))
- (i 0))
- (while (< i 256)
- (aset vector i (aref dt i))
- (incf i))
+ (i 0))
+ (while (< i 256)
+ (aset vector i (aref dt i))
+ (incf i))
;; FSF calls `describe-vector' here, but it is so incredibly
;; lame a function for that name that I cannot bring myself
;; to porting it. Here is what `describe-vector' does:
(list (cons fdt-locale
(mapcar
(lambda (fdt-x)
- (funcall fdt-function (cdr fdt-x))
- fdt-x)
+ (funcall fdt-function (cdr fdt-x))
+ fdt-x)
(cdar (specifier-spec-list current-display-table
fdt-locale)))))))
(frob-display-table
(lambda (x)
(if (or (<= (prefix-numeric-value arg) 0)
- (and (null arg)
- (equal (aref x 160) (char-to-string 160))))
- (standard-display-default-1 x 160 255)
+ (and (null arg)
+ (equal (aref x 160) (char-to-string 160))))
+ (standard-display-default-1 x 160 255)
(standard-display-8bit-1 x 160 255)))
locale))
(switch-to-buffer (find-file-noselect
(substring (car data) 5))))
;; to-do: open ftp URLs with efs...
- (t
+ (t
;; some other URL, try to fire up some browser for it
(if-fboundp 'browse-url
(browse-url (car data))
;; insert drops of text/* into buffer
;; create new buffer if pointer is outside buffer...
;; but there are many other ways...
- ;;
+ ;;
;; first thing: check if it's only text/plain and if the
;; drop happened inside some buffer. if yes insert it into
;; this buffer (hope it is not encoded in some MIME way)
(defun experimental-dragdrop-drag (event object)
"*{EXPERIMENTAL} The generic drag function.
Tries to do the best with object in the selected protocol.
-Object must comply to the standart drag'n'drop object
+Object must comply to the standart drag'n'drop object
format."
(error "Not implemented"))
(when debug-paths
(princ (format "SXEmacs thinks the roots of its hierarchy are:\n%S\n"
- roots)))
+ roots)))
(let* ((package-locations
(packages-compute-package-locations
(setq mule-lisp-directory '()))
(setq ffi-lisp-directory
- (when (fboundp #'ffi-defun)
- (paths-find-ffi-lisp-directory roots
- lisp-directory)))
+ (when (fboundp #'ffi-defun)
+ (paths-find-ffi-lisp-directory roots
+ lisp-directory)))
(setq load-path (paths-construct-load-path roots
'()
lisp-directory
nil
mule-lisp-directory
- ffi-lisp-directory))
+ ffi-lisp-directory))
(setq exec-directory (paths-find-exec-directory roots))
(if debug-paths
(setq preloaded-file-list
(assemble-list
- "backquote" ; needed for defsubst etc.
+ "backquote" ; needed for defsubst etc.
"bytecomp-runtime" ; define defsubst
"find-paths"
"packages" ; Bootstrap run-time lisp environment
"setup-paths"
"dump-paths"
- "subr" ; load the most basic Lisp functions
- "replace" ; match-string used in version.el.
+ "subr" ; load the most basic Lisp functions
+ "replace" ; match-string used in version.el.
; Ignore compiled-by-mistake version.elc
"version.el"
"cl"
"simple"
"keydefs" ; Before loaddefs so that keymap vars exist.
"abbrev"
- "number"
+ "number"
"derived"
"minibuf"
"list-mode"
"lisp-initd"
"misc"
"loadhist" ; Must be dumped before loaddefs is loaded
- ; Used by help.
+ ; Used by help.
;; (pureload "profile")
(unless-feature mule "help-nomule")
"help"
;; preload the TTY init code.
(when-feature tty "tty-init")
- "x-color"
- "cus-face"
- "font-lock"
+ "x-color"
+ "cus-face"
+ "font-lock"
"fontl-hooks"
"auto-show"
(when-feature ldap "ldap")
These following keyword arguments are supported:
:group GROUP Custom group name to use in all generated `defcustom' forms.
:global GLOBAL If non-nil specifies that the minor mode is not meant to be
- buffer-local, so don't make the variable MODE buffer-local.
+ buffer-local, so don't make the variable MODE buffer-local.
By default, the mode is buffer-local.
:init-value VAL Same as the INIT-VALUE argument.
:lighter SPEC Same as the LIGHTER argument.
MODE-hook: run if the mode is toggled.
MODE-on-hook: run if the mode is activated.
MODE-off-hook: run if the mode is deactivated.
-
+
\(defmacro easy-mmode-define-minor-mode
(MODE DOC &optional INIT-VALUE LIGHTER KEYMAP &rest BODY)...\)
;; Add default properties to LIGHTER.
;; #### FSF comments this out in 21.3.
; (unless (or (not (stringp lighter))
-; (get-text-property 0 'local-map lighter)
-; (get-text-property 0 'keymap lighter))
+; (get-text-property 0 'local-map lighter)
+; (get-text-property 0 'keymap lighter))
; (setq lighter
-; (propertize lighter
-; 'local-map modeline-minor-mode-map ; XEmacs change
-; 'help-echo "mouse-3: minor mode menu")))
+; (propertize lighter
+; 'local-map modeline-minor-mode-map ; XEmacs change
+; 'help-echo "mouse-3: minor mode menu")))
`(progn
;; Define the variable to enable or disable the mode.
defined:
toggle: A checkbox.
- Currently just prepend the name with the string \"Toggle \".
+ Currently just prepend the name with the string \"Toggle \".
radio: A radio button.
nil: An ordinary menu item.
;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;; Commentary:
-;;
+;;
;; Here are a number of utils for interacting with emodules, such
;; as finding them, loading them. That sort of thing.
;;
;;; Todo:
;;
-;;
+;;
;;; Code:
(defvar emodule-completions nil
If the CDR of the elements of this list are strings, then they are
assumed to name a TAGS file. If they name a directory, then the string
-\"TAGS\" is appended to them to get the file name. If they are not
+\"TAGS\" is appended to them to get the file name. If they are not
strings, then they are evaluated, and must return an appropriate string.
For example:
table that is searched before all others when find-tag is executed from this
buffer.
-If there is a file called \"TAGS\" in the same directory as the file in
+If there is a file called \"TAGS\" in the same directory as the file in
question, then that tags file will always be used as well (after the
`buffer-tag-table' but before the tables specified by this list.)
:group 'etags)
(defcustom make-tags-files-invisible nil
- "*If non-nil, TAGS-files will not show up in buffer-lists or be
+ "*If non-nil, TAGS-files will not show up in buffer-lists or be
selectable (or deletable.)"
:type 'boolean
:group 'etags)
(defcustom tags-exuberant-ctags-optimization-p nil
"*If this variable is nil (the default), then exact tag search is able
to find tag names in the name part of the tagtable (enclosed by ^?..^A)
-and in the sourceline part of the tagtable ( enclosed by ^..^?).
+and in the sourceline part of the tagtable ( enclosed by ^..^?).
This is needed by xemacs etags as not every tag has a name field.
It is slower for large tables and less precise than the other option.
;; Buffer tag tables.
(defun buffer-tag-table-list ()
- "Returns a list (ordered) of the tags tables which should be used for
+ "Returns a list (ordered) of the tags tables which should be used for
the current buffer."
(let (result)
;; Explicitly set buffer-tag-table
default-directory
(expand-file-name "TAGS" default-directory)
t)))
- (if (string-equal file "")
+ (if (string-equal file "")
(setq tags-file-name nil)
(setq file (expand-file-name file))
(when (file-directory-p file)
#'string<))
(defun buffer-tag-table-files ()
- "Returns a list of all files referenced by all TAGS tables that
+ "Returns a list of all files referenced by all TAGS tables that
this buffer uses."
(when (zerop (bloom-size tag-table-files-bloom))
(tag-loop for table in (buffer-tag-table-list)
(autoload 'get-symbol-syntax-table "symbol-syntax")
(defun find-tag-internal (tagname)
-
+
(let ((next (null tagname))
(tmpnext (null tagname))
;; If tagname is a list: (TAGNAME), this indicates
(setq tag-table-currently-matching-exact t)))
;; \_ in the tagname is used to indicate a symbol boundary.
(if tags-exuberant-ctags-optimization-p
- (setq exact-tagname (format "\C-?%s\C-a" tagname))
+ (setq exact-tagname (format "\C-?%s\C-a" tagname))
(setq exact-tagname (format "\C-?%s\C-a\\|\
\\_%s.?\C-?[0-9]*,[0-9]*$" tagname tagname))
)
if the file was newly read in, the value is the filename."
(interactive "P")
(cond ((not initialize)
- ;; Not the first run.
- )
- ((eq initialize t)
- ;; Initialize the list from the tags table.
+ ;; Not the first run.
+ )
+ ((eq initialize t)
+ ;; Initialize the list from the tags table.
(setq next-file-list (buffer-tag-table-files)))
- (t
- ;; Initialize the list by evalling the argument.
- (setq next-file-list (eval initialize))))
+ (t
+ ;; Initialize the list by evalling the argument.
+ (setq next-file-list (eval initialize))))
(when (null next-file-list)
(and novisit
(get-buffer " *next-file*")
(pop next-file-list)
(if (not (and new novisit))
- (switch-to-buffer (find-file-noselect file novisit) t)
+ (switch-to-buffer (find-file-noselect file novisit) t)
;; Like find-file, but avoids random junk.
(set-buffer (get-buffer-create " *next-file*"))
(kill-all-local-variables)
(interactive)
(let ((messaged nil)
(more-files-p t)
- new)
+ new)
(while more-files-p
;; Scan files quickly for the first or next interesting one.
(while (or first-time
;; If value is non-nil, continue to scan the next file.
(setq more-files-p (eval tags-loop-operate)))
(and messaged
- (null tags-loop-operate)
- (message "Scanning file %s...found" buffer-file-name))))
+ (null tags-loop-operate)
+ (message "Scanning file %s...found" buffer-file-name))))
;;;###autoload
(defun tags-search (regexp &optional file-list-form)
See documentation of variable `tag-table-alist'."
(interactive "sTags search (regexp): ")
(if (and (equal regexp "")
- (eq (car tags-loop-scan) 'with-search-caps-disable-folding)
- (null tags-loop-operate))
+ (eq (car tags-loop-scan) 'with-search-caps-disable-folding)
+ (null tags-loop-operate))
;; Continue last tags-search as if by `M-,'.
(tags-loop-continue nil)
(setq tags-loop-scan `(with-search-caps-disable-folding ,regexp t
- (re-search-forward ,regexp nil t))
- tags-loop-operate nil)
+ (re-search-forward ,regexp nil t))
+ tags-loop-operate nil)
(tags-loop-continue (or file-list-form t))))
;;;###autoload
(interactive
"sTags query replace (regexp): \nsTags query replace %s by: \nP")
(setq tags-loop-scan `(with-search-caps-disable-folding ,from t
- (if (re-search-forward ,from nil t)
- ;; When we find a match, move back
- ;; to the beginning of it so perform-replace
- ;; will see it.
- (progn (goto-char (match-beginning 0)) t)))
- tags-loop-operate (list 'perform-replace from to t t
- (not (null delimited))))
+ (if (re-search-forward ,from nil t)
+ ;; When we find a match, move back
+ ;; to the beginning of it so perform-replace
+ ;; will see it.
+ (progn (goto-char (match-beginning 0)) t)))
+ tags-loop-operate (list 'perform-replace from to t t
+ (not (null delimited))))
(tags-loop-continue (or file-list-form t)))
\f
;; Miscellaneous
;; bindings of the corresponding keys by default, but that made the display
;; of M-x describe-bindings much harder to read, so now we'll just bind them
;; to self-insert by default. Not a big difference...
-
+
(put 'kp-0 'ascii-character ?0)
(put 'kp-1 'ascii-character ?1)
(put 'kp-2 'ascii-character ?2)
PREDICATE or FUNCTION. See also `map-extents'."
(let (*result*)
(map-extents (if predicate
- #'(lambda (ex junk)
- (and (funcall predicate ex)
- (setq *result* (cons (funcall function ex)
- *result*)))
- nil)
- #'(lambda (ex junk)
- (setq *result* (cons (funcall function ex)
- *result*))
- nil))
- buffer-or-string from to nil flags property value)
+ #'(lambda (ex junk)
+ (and (funcall predicate ex)
+ (setq *result* (cons (funcall function ex)
+ *result*)))
+ nil)
+ #'(lambda (ex junk)
+ (setq *result* (cons (funcall function ex)
+ *result*))
+ nil))
+ buffer-or-string from to nil flags property value)
(nreverse *result*)))
(defun extent-list (&optional buffer-or-string from to flags property value)
The following symbols have predefined meanings:
foreground The foreground color of the face.
- For valid instantiators, see `make-color-specifier'.
+ For valid instantiators, see `make-color-specifier'.
background The background color of the face.
- For valid instantiators, see `make-color-specifier'.
+ For valid instantiators, see `make-color-specifier'.
font The font used to display text covered by this face.
- For valid instantiators, see `make-font-specifier'.
+ For valid instantiators, see `make-font-specifier'.
display-table The display table of the face.
- This should be a vector of 256 elements.
+ This should be a vector of 256 elements.
background-pixmap The pixmap displayed in the background of the face.
- Only used by faces on X and MS Windows devices.
- For valid instantiators, see `make-image-specifier'.
+ Only used by faces on X and MS Windows devices.
+ For valid instantiators, see `make-image-specifier'.
underline Underline all text covered by this face.
- For valid instantiators, see `make-face-boolean-specifier'.
+ For valid instantiators, see `make-face-boolean-specifier'.
strikethru Draw a line through all text covered by this face.
- For valid instantiators, see `make-face-boolean-specifier'.
+ For valid instantiators, see `make-face-boolean-specifier'.
highlight Highlight all text covered by this face.
- Only used by faces on TTY devices.
- For valid instantiators, see `make-face-boolean-specifier'.
+ Only used by faces on TTY devices.
+ For valid instantiators, see `make-face-boolean-specifier'.
dim Dim all text covered by this face.
- For valid instantiators, see `make-face-boolean-specifier'.
+ For valid instantiators, see `make-face-boolean-specifier'.
blinking Blink all text covered by this face.
- Only used by faces on TTY devices.
- For valid instantiators, see `make-face-boolean-specifier'.
+ Only used by faces on TTY devices.
+ For valid instantiators, see `make-face-boolean-specifier'.
reverse Reverse the foreground and background colors.
- Only used by faces on TTY devices.
- For valid instantiators, see `make-face-boolean-specifier'.
+ Only used by faces on TTY devices.
+ For valid instantiators, see `make-face-boolean-specifier'.
inherit Face name or face object from which to inherit attributes,
- or a list of such elements. Attributes from inherited
- faces are merged into the face like an underlying face
- would be, with higher priority than underlying faces.
+ or a list of such elements. Attributes from inherited
+ faces are merged into the face like an underlying face
+ would be, with higher priority than underlying faces.
doc-string Description of what the face's normal use is.
- NOTE: This is not a specifier, unlike all
- the other built-in properties, and cannot
- contain locale-specific values."
+ NOTE: This is not a specifier, unlike all
+ the other built-in properties, and cannot
+ contain locale-specific values."
(setq face (get-face face))
(if (memq property built-in-face-specifiers)
(and (face-equal-loop common-props face1 face2 domain)
(cond ((eq 'tty (device-type device))
(face-equal-loop tty-props face1 face2 domain))
- ;; #### Why isn't this (console-on-window-system-p (device-console device))?
- ;; #### FIXME!
+ ;; #### Why isn't this (console-on-window-system-p (device-console device))?
+ ;; #### FIXME!
((eq 'x (device-type device))
(face-equal-loop win-props face1 face2 domain))
(t t)))))
(when (not (specifier-specs temp-sp 'global))
;; Try fallback via the official ways and then do it "by hand"
(let* ((fallback (specifier-fallback sp))
- (fallback-sp
+ (fallback-sp
(cond ((specifierp fallback) fallback)
;; just an inst list
(fallback
(if (not first-valid)
(setq first-valid inst-pair))
(setq result (funcall func sp-inst device))
- (if result
- (setq result (cons tag-set result))))))
+ (if result
+ (setq result (cons tag-set result))))))
(setq inst-list (cdr inst-list)))
(or result first-valid)))
;; Size frobbing
;; Thx Jan Vroonhof, Ref xemacs-beta <87oflypbum.fsf@petteflet.ntlworld.com>
-;; Jan had a separate helper function
+;; Jan had a separate helper function
(defun make-face-size (face size &optional locale tags)
"Adjust FACE to SIZE in LOCALE, if possible.
set-face-background-pixmap instead.
PIXMAP should be a string, the name of a file of pixmap data.
-The directories listed in the variable `x-bitmap-file-path'
+The directories listed in the variable `x-bitmap-file-path'
under X is searched.
Alternatively, PIXMAP may be a list of the form (WIDTH HEIGHT
(globally-declare-fboundp
'(ffi-size-of-type make-ffi-object ffi-canonicalise-type
ffi-basic-type-p ffi-load-library ffi-dlerror
- ffi-object-type ffi-fetch ffi-slot-offset
- ffi-store ffi-aref ffi-make-pointer
- ffi-object-address ffi-call-function
- ffi-defun ffi-bind)))
+ ffi-object-type ffi-fetch ffi-slot-offset
+ ffi-store ffi-aref ffi-make-pointer
+ ffi-object-address ffi-call-function
+ ffi-defun ffi-bind)))
\f
(require 'alist)
"Create a foreign object of TYPE and set its value to VAL.
Return created FFI object."
(let* ((ctype (ffi-canonicalise-type type))
- (size (cond ((or (eq ctype 'c-string) (eq ctype 'c-data))
- (1+ (length val)))
- ((and (consp ctype) (eq (car ctype) 'c-data)
- (intp (cdr ctype)))
- (cdr ctype))
- (t
- (ffi-size-of-type ctype))))
- (fo (make-ffi-object type size)))
+ (size (cond ((or (eq ctype 'c-string) (eq ctype 'c-data))
+ (1+ (length val)))
+ ((and (consp ctype) (eq (car ctype) 'c-data)
+ (intp (cdr ctype)))
+ (cdr ctype))
+ (t
+ (ffi-size-of-type ctype))))
+ (fo (make-ffi-object type size)))
(ffi-set fo val)
fo))
(defmacro ffi-translate-foreign (value type translators)
`(let ((translator (assq ,type ,translators)))
(if translator
- (eval (cdr translator))
+ (eval (cdr translator))
value)))
(defun ffi-translate-to-foreign (value type)
;; Try to get name from union or struct
(when (and (null name)
- (listp type)
- (memq (car type) '(struct union)))
+ (listp type)
+ (memq (car type) '(struct union)))
(setq name (cadr type)))
(setq ffi-named-types
- (put-alist name type ffi-named-types))
+ (put-alist name type ffi-named-types))
;; Copy translators, if any
(let ((fft (assq type ffi-type-to-translators))
- (tft (assq type ffi-type-from-translators)))
+ (tft (assq type ffi-type-from-translators)))
(when fft
- (pushnew (cons name (cdr fft)) ffi-type-to-translators :key #'car))
+ (pushnew (cons name (cdr fft)) ffi-type-to-translators :key #'car))
(when tft
- (pushnew (cons name (cdr tft)) ffi-type-from-translators :key #'car)))
+ (pushnew (cons name (cdr tft)) ffi-type-from-translators :key #'car)))
name))
"Define a new structure of NAME and SLOTS.
SLOTS are in form (NAME TYPE &key :offset)."
(let ((forms `(progn
- (define-ffi-type ,name (struct ,name ,@slots)))))
+ (define-ffi-type ,name (struct ,name ,@slots)))))
(loop for sn in slots
do (setq sn (car sn))
do (let ((sym (intern (format "%S->%S" name sn))))
- (setq forms (append forms
- `((defun ,sym (obj)
- (ffi-fetch obj (ffi-slot-offset ',name ',sn)
- (ffi-slot-type ',name ',sn))))))
- (setq forms
- (append forms
- `((defsetf ,sym (obj) (nv)
- (list 'ffi-store obj
- (list 'ffi-slot-offset '',name '',sn)
- (list 'ffi-slot-type '',name '',sn)
- nv)))))))
+ (setq forms (append forms
+ `((defun ,sym (obj)
+ (ffi-fetch obj (ffi-slot-offset ',name ',sn)
+ (ffi-slot-type ',name ',sn))))))
+ (setq forms
+ (append forms
+ `((defsetf ,sym (obj) (nv)
+ (list 'ffi-store obj
+ (list 'ffi-slot-offset '',name '',sn)
+ (list 'ffi-slot-type '',name '',sn)
+ nv)))))))
forms))
;;;###autoload
(setq type (ffi-canonicalise-type type))
(if (cond ((ffi-basic-type-p type) type)
- ;; Pointer
- ((or (eq type 'pointer)
- (and (listp type)
- (eq (car type) 'pointer)
- (ffi-type-p (cadr type)))) type)
+ ;; Pointer
+ ((or (eq type 'pointer)
+ (and (listp type)
+ (eq (car type) 'pointer)
+ (ffi-type-p (cadr type)))) type)
- ;; Maybe TYPE is declared
- ((ffi-declared-type-p type) type)
+ ;; Maybe TYPE is declared
+ ((ffi-declared-type-p type) type)
- ;; Struct or Union
- ((and (listp type)
- (memq (car type) '(struct union)))
- type)
+ ;; Struct or Union
+ ((and (listp type)
+ (memq (car type) '(struct union)))
+ type)
; (not (memq nil
; (mapcar #'(lambda (slot-type)
; (ffi-type-p (cadr slot-type)))
; (cddr type)))))
- ;; Complex c-data
- ((and (consp type) (eq (car type) 'c-data)
- (or (numberp (cdr type)) (null (cdr type))))
- type)
-
- ;; Array
- ((and (listp type) (eq 'array (car type))
- (ffi-type-p (cadr type))
- (integerp (caddr type))
- (> (caddr type) 0))
- type)
-
- ;; Function
- ((and (listp type) (eq 'function (car type))
- (ffi-type-p (cadr type)))
- (not (memq nil (mapcar 'ffi-type-p (cddr type))))))
+ ;; Complex c-data
+ ((and (consp type) (eq (car type) 'c-data)
+ (or (numberp (cdr type)) (null (cdr type))))
+ type)
+
+ ;; Array
+ ((and (listp type) (eq 'array (car type))
+ (ffi-type-p (cadr type))
+ (integerp (caddr type))
+ (> (caddr type) 0))
+ type)
+
+ ;; Function
+ ((and (listp type) (eq 'function (car type))
+ (ffi-type-p (cadr type)))
+ (not (memq nil (mapcar 'ffi-type-p (cddr type))))))
type ; TYPE is valid FFI type
(when signal-p
(error "Can't load library `%s': %s" libname (ffi-dlerror)))
(setq ffi-loaded-libraries
- (put-alist libname fo ffi-loaded-libraries))
+ (put-alist libname fo ffi-loaded-libraries))
fo))
(defun* ffi-get (fo &key (type (ffi-object-type fo)) (off 0)
- (from-call nil))
+ (from-call nil))
"Return FO's value.
Optional key :TYPE may be used to cast FO to the specified
type, it defaults to the object's assigned type.
FROM-CALL is magic, do not use it!"
(let ((ctype (ffi-canonicalise-type type)))
(cond ((ffi-basic-type-p ctype)
- (ffi-fetch fo off type))
- ;; Arrays
- ((and (listp ctype)
- (eq (car ctype) 'array))
- (vconcat
- (loop for idx from 0 below (third ctype)
- collect (ffi-get
- fo :type (second ctype)
- :off (+ off (* idx (ffi-size-of-type
- (second ctype))))))))
-
- ;; Structures
- ((and (listp ctype)
- (eq (car ctype) 'struct))
- (loop for sslot in (cddr ctype)
- collect (list (first sslot)
- (ffi-get
- fo :type (second sslot)
- :off (+ off (ffi-slot-offset
- ctype (first sslot)))))))
-
- ;; Extremely special case for safe-string!
- ((eq type 'safe-string)
- (unless (ffi-null-p fo)
- (ffi-fetch fo off 'c-string)))
-
- ((and (not from-call)
- (or (eq ctype 'pointer)
- (and (listp ctype)
- (eq (car ctype) 'pointer)
- (ffi-type-p (cadr ctype)))))
- (if (ffi-null-p fo)
- nil
- (ffi-fetch fo off type)))
-
- (t
- ;; Can't get value in proper form,
- ;; just return FO unmodified
- fo))))
+ (ffi-fetch fo off type))
+ ;; Arrays
+ ((and (listp ctype)
+ (eq (car ctype) 'array))
+ (vconcat
+ (loop for idx from 0 below (third ctype)
+ collect (ffi-get
+ fo :type (second ctype)
+ :off (+ off (* idx (ffi-size-of-type
+ (second ctype))))))))
+
+ ;; Structures
+ ((and (listp ctype)
+ (eq (car ctype) 'struct))
+ (loop for sslot in (cddr ctype)
+ collect (list (first sslot)
+ (ffi-get
+ fo :type (second sslot)
+ :off (+ off (ffi-slot-offset
+ ctype (first sslot)))))))
+
+ ;; Extremely special case for safe-string!
+ ((eq type 'safe-string)
+ (unless (ffi-null-p fo)
+ (ffi-fetch fo off 'c-string)))
+
+ ((and (not from-call)
+ (or (eq ctype 'pointer)
+ (and (listp ctype)
+ (eq (car ctype) 'pointer)
+ (ffi-type-p (cadr ctype)))))
+ (if (ffi-null-p fo)
+ nil
+ (ffi-fetch fo off type)))
+
+ (t
+ ;; Can't get value in proper form,
+ ;; just return FO unmodified
+ fo))))
(defun ffi-slot-type (type slot)
"Return TYPE's SLOT type.
(unless (memq (car ctype) '(struct union))
(error "Not struct or union: %S" type))
(or (cadr (find slot (cddr ctype) :key #'car :test #'eq))
- (error "No such slot: %S" slot))))
+ (error "No such slot: %S" slot))))
(defun ffi-slot (fo slot)
"Setf-able slot accessor.
(defun ffi-set (fo val)
"Set FO's foreign value to VAL."
(let* ((type (ffi-object-type fo))
- (ctype (ffi-canonicalise-type type)))
+ (ctype (ffi-canonicalise-type type)))
(if (or (ffi-basic-type-p ctype)
- (eq ctype 'pointer))
- (ffi-store fo 0 type val)
+ (eq ctype 'pointer))
+ (ffi-store fo 0 type val)
;; Pointer type, same as for basic
(when (or (eq ctype 'pointer)
- (and (listp ctype) (eq (car ctype) 'pointer)))
- (ffi-store fo 0 type val))
+ (and (listp ctype) (eq (car ctype) 'pointer)))
+ (ffi-store fo 0 type val))
;; TODO: Compound type
)))
(defun ,fsym ,args
,doc-string
(let ((ffiargs nil)
- (ret nil))
- (mapcar* #'(lambda (type arg)
- (setq ffiargs (cons
- (if (ffi-object-p arg)
- arg
- (ffi-create-fo type arg))
- ffiargs)))
- (cddr ,ftype) (list ,@args))
- (setq ffiargs (nreverse ffiargs))
- (setq ret (apply #'ffi-call-function ,fsym ffiargs))
- (ffi-get ret :from-call t)))))
+ (ret nil))
+ (mapcar* #'(lambda (type arg)
+ (setq ffiargs (cons
+ (if (ffi-object-p arg)
+ arg
+ (ffi-create-fo type arg))
+ ffiargs)))
+ (cddr ,ftype) (list ,@args))
+ (setq ffiargs (nreverse ffiargs))
+ (setq ret (apply #'ffi-call-function ,fsym ffiargs))
+ (ffi-get ret :from-call t)))))
(put 'define-ffi-function 'lisp-indent-function 'defun)
;; now build that pig of code
(list 'prog1
- ;; define the constant `name'
- (list 'defconst name nil
- docstring)
- ;; fill in the values
- (list 'setq name
- (cons 'list
- (let ((tmpspecs specs)
- (i 0)
- (delayed (dllist))
- (result (dllist)))
- (while (car tmpspecs)
- (if (eq (cadr tmpspecs) '=)
- ;; this is the alias case
- ;; we append a cons (left-of-= . right-of-=)
- ;; to the dllist `delayed'
- ;; if `right-of-=' (i.e. the caddr) is an integer
- ;; we set the counter `i' to that value on go on
- ;; from there
- (let ((leftof (car tmpspecs))
- (rightof (caddr tmpspecs)))
-
- ;; pop off the cruft
- (setq tmpspecs (nthcdr 3 tmpspecs))
-
- (cond ((intp rightof)
- ;; reset the counter
- (setq i rightof)
- ;; prepend leftof again
- (setq tmpspecs
- (cons leftof tmpspecs)))
- (t
- ;; push the stuff to the delayed list
- (dllist-append
- delayed (cons leftof rightof)))))
-
- ;; ordinary case
- (dllist-append result (cons (car tmpspecs) i))
- (setq i (1+ i))
- (setq tmpspecs (cdr tmpspecs))))
-
- ;; convert `result' to alist
- ;; this is necessary here, since we need the alist
- ;; property right now to look up the delayed symbols
- (setq result (dllist-to-list result))
-
- ;; process those delayed thingies
- ;; these are basically conses (alias . resolved-symbol)
- ;; we lookup `resolved-symbol' in the alist `result'
- ;; first and assign (alias . value-of-resolved-symbol)
- ;; if that fails, we look at the cars of the delayed
- ;; list if we can find `resolved-symbol' there
- ;; if so, we re-append the whole cell to the delayed list
- ;; if not, we try to find a huge horsewhip to treat
- ;; the user to a little surprise :)
- (while (dllist-car delayed)
- (let ((alias (dllist-pop-car delayed)))
- (let ((val (cdr-safe (assoc (cdr alias) result))))
- (if (null val)
- ;; prevent infinite loops when the user
- ;; is too stupid to give us a valid alias
- (when (let ((presentp))
- (mapc-internal
- #'(lambda (item)
- (and (eq (cdr alias) (car item))
- (setq presentp t)))
- delayed)
- presentp)
- (dllist-append delayed alias))
- (setq result
- (cons (cons (car alias) val)
- result))))))
-
- ;; return `result'
- (mapcar
- #'(lambda (rescell)
- (list 'cons
- (list 'quote (car rescell))
- (list
- 'let
- (list (list 'ffival
- (list 'ffi-create-fo
- ''unsigned-int
- (cdr rescell))))
- (list 'put 'ffival ''value (cdr rescell))
- 'ffival)))
- result))))
-
- ;; define the lookup function
- (list 'defun name '(symbol)
- (format "Lookup the value of SYMBOL in the enumeration `%s'."
- name)
- (list 'cdr-safe
- (list 'assq 'symbol
- name)))
-
- ;; define the lookup function for the elisp value
- (list 'defun (intern (format "%s-value" name)) '(symbol)
- (format (concat "Lookup the elisp value (an integer) of SYMBOL "
- "in the enumeration `%s'.")
- name)
- (list 'get (list name 'symbol) ''value))))
+ ;; define the constant `name'
+ (list 'defconst name nil
+ docstring)
+ ;; fill in the values
+ (list 'setq name
+ (cons 'list
+ (let ((tmpspecs specs)
+ (i 0)
+ (delayed (dllist))
+ (result (dllist)))
+ (while (car tmpspecs)
+ (if (eq (cadr tmpspecs) '=)
+ ;; this is the alias case
+ ;; we append a cons (left-of-= . right-of-=)
+ ;; to the dllist `delayed'
+ ;; if `right-of-=' (i.e. the caddr) is an integer
+ ;; we set the counter `i' to that value on go on
+ ;; from there
+ (let ((leftof (car tmpspecs))
+ (rightof (caddr tmpspecs)))
+
+ ;; pop off the cruft
+ (setq tmpspecs (nthcdr 3 tmpspecs))
+
+ (cond ((intp rightof)
+ ;; reset the counter
+ (setq i rightof)
+ ;; prepend leftof again
+ (setq tmpspecs
+ (cons leftof tmpspecs)))
+ (t
+ ;; push the stuff to the delayed list
+ (dllist-append
+ delayed (cons leftof rightof)))))
+
+ ;; ordinary case
+ (dllist-append result (cons (car tmpspecs) i))
+ (setq i (1+ i))
+ (setq tmpspecs (cdr tmpspecs))))
+
+ ;; convert `result' to alist
+ ;; this is necessary here, since we need the alist
+ ;; property right now to look up the delayed symbols
+ (setq result (dllist-to-list result))
+
+ ;; process those delayed thingies
+ ;; these are basically conses (alias . resolved-symbol)
+ ;; we lookup `resolved-symbol' in the alist `result'
+ ;; first and assign (alias . value-of-resolved-symbol)
+ ;; if that fails, we look at the cars of the delayed
+ ;; list if we can find `resolved-symbol' there
+ ;; if so, we re-append the whole cell to the delayed list
+ ;; if not, we try to find a huge horsewhip to treat
+ ;; the user to a little surprise :)
+ (while (dllist-car delayed)
+ (let ((alias (dllist-pop-car delayed)))
+ (let ((val (cdr-safe (assoc (cdr alias) result))))
+ (if (null val)
+ ;; prevent infinite loops when the user
+ ;; is too stupid to give us a valid alias
+ (when (let ((presentp))
+ (mapc-internal
+ #'(lambda (item)
+ (and (eq (cdr alias) (car item))
+ (setq presentp t)))
+ delayed)
+ presentp)
+ (dllist-append delayed alias))
+ (setq result
+ (cons (cons (car alias) val)
+ result))))))
+
+ ;; return `result'
+ (mapcar
+ #'(lambda (rescell)
+ (list 'cons
+ (list 'quote (car rescell))
+ (list
+ 'let
+ (list (list 'ffival
+ (list 'ffi-create-fo
+ ''unsigned-int
+ (cdr rescell))))
+ (list 'put 'ffival ''value (cdr rescell))
+ 'ffival)))
+ result))))
+
+ ;; define the lookup function
+ (list 'defun name '(symbol)
+ (format "Lookup the value of SYMBOL in the enumeration `%s'."
+ name)
+ (list 'cdr-safe
+ (list 'assq 'symbol
+ name)))
+
+ ;; define the lookup function for the elisp value
+ (list 'defun (intern (format "%s-value" name)) '(symbol)
+ (format (concat "Lookup the elisp value (an integer) of SYMBOL "
+ "in the enumeration `%s'.")
+ name)
+ (list 'get (list name 'symbol) ''value))))
(put 'ffi-enum 'lisp-indent-function 'defun)
;;; example
;; (ffi-enum example-enum
`(progn
(define-ffi-type ,type-name int)
(let* ((cv 0)
- (fev (mapcar #'(lambda (sv)
- (prog1
- (if (and (listp sv)
- (symbolp (car sv))
- (numberp (cadr sv)))
- (prog1
- (cons (car sv) (cadr sv))
- (setq cv (cadr sv)))
- (cons sv cv))
- (incf cv)))
- '(,@spec))))
+ (fev (mapcar #'(lambda (sv)
+ (prog1
+ (if (and (listp sv)
+ (symbolp (car sv))
+ (numberp (cadr sv)))
+ (prog1
+ (cons (car sv) (cadr sv))
+ (setq cv (cadr sv)))
+ (cons sv cv))
+ (incf cv)))
+ '(,@spec))))
(put ',type-name 'ffi-enum-values fev))
;; Translators
(define-ffi-translator-to-foreign ,type-name
(or (cdr (assq value (get ',type-name 'ffi-enum-values)))
- 0))
+ 0))
(define-ffi-translator-from-foreign ,type-name
(or (car (find-if #'(lambda (v)
- (= (cdr v) value))
- (get ',type-name 'ffi-enum-values)))
- 'undefined-enum-value))))
+ (= (cdr v) value))
+ (get ',type-name 'ffi-enum-values)))
+ 'undefined-enum-value))))
(defun ffi-enum-values (enum-type)
"Return alist for ENUM-TYPE.
To get foreign object for this callback function use `ffi-callback-fo'
and pass the name of the callback."
(let ((argnames (mapcar #'first args))
- (argtypes (mapcar #'second args)))
+ (argtypes (mapcar #'second args)))
`(progn
(defun ,sym ,argnames
,@body)
(etypecase name
(list (second name))
(string (intern (format "%s%s%s" (if fun-p "" "*")
- (downcase (substitute ?- ?_ name)) (if fun-p "" "*"))))
+ (downcase (substitute ?- ?_ name)) (if fun-p "" "*"))))
(symbol name)))
(defun cffi:foreign-var-name (name)
(list (first name))
(string name)
(symbol (let ((dname (downcase (symbol-name name))))
- (replace-in-string (substitute ?_ ?- dname) "\\*" "")))))
+ (replace-in-string (substitute ?_ ?- dname) "\\*" "")))))
(defun cffi:get-var-pointer (symbol)
"Return a pointer to the foreign global variable relative to SYMBOL."
(unless (null docstring)
(setq in-args (cons docstring in-args)))
(setq docstring
- (format "Lisp variant for `%s' foreign function."
- (cffi:foreign-var-name name))))
+ (format "Lisp variant for `%s' foreign function."
+ (cffi:foreign-var-name name))))
(let* ((nsl (cffi:lisp-var-name name t))
- (nsf (cffi:foreign-var-name name))
- (with-rest (when (eq (car (last in-args)) '&rest)
- (setq in-args (butlast in-args))
- t))
- (as (mapcar 'first in-args))
- (at (mapcar 'second in-args))
- (flet-form) (defun-form nil))
+ (nsf (cffi:foreign-var-name name))
+ (with-rest (when (eq (car (last in-args)) '&rest)
+ (setq in-args (butlast in-args))
+ t))
+ (as (mapcar 'first in-args))
+ (at (mapcar 'second in-args))
+ (flet-form) (defun-form nil))
(setq flet-form
- (append (list `(mapcar* #'setarg ',at (list ,@as)))
- (when with-rest
- (list '(while rest-args
- (if (ffi-object-p (car rest-args))
- (progn
- (setarg (ffi-object-type (car rest-args))
- (car rest-args))
- (setq rest-args (cdr rest-args)))
- (setarg (car rest-args) (cadr rest-args))
- (setq rest-args (cddr rest-args))))))
- (list '(setq ffiargs (nreverse ffiargs)))
- (list `(setq ret (apply #'ffi-call-function
- (get ',nsl 'ffi-fun) ffiargs)))
- (list `(ffi-get ret :from-call t))))
+ (append (list `(mapcar* #'setarg ',at (list ,@as)))
+ (when with-rest
+ (list '(while rest-args
+ (if (ffi-object-p (car rest-args))
+ (progn
+ (setarg (ffi-object-type (car rest-args))
+ (car rest-args))
+ (setq rest-args (cdr rest-args)))
+ (setarg (car rest-args) (cadr rest-args))
+ (setq rest-args (cddr rest-args))))))
+ (list '(setq ffiargs (nreverse ffiargs)))
+ (list `(setq ret (apply #'ffi-call-function
+ (get ',nsl 'ffi-fun) ffiargs)))
+ (list `(ffi-get ret :from-call t))))
(setq defun-form
- (append `(defun ,nsl)
- (list (if with-rest
- (append as '(&rest rest-args))
- as))
- (list docstring)
- (list (append
- '(let (ffiargs ret))
- (list (append
- '(flet ((setarg (type arg)
- (setq ffiargs
- (cons
- (if (ffi-object-p arg)
- arg
- (ffi-create-fo type arg))
- ffiargs)))))
- flet-form))
- ))))
+ (append `(defun ,nsl)
+ (list (if with-rest
+ (append as '(&rest rest-args))
+ as))
+ (list docstring)
+ (list (append
+ '(let (ffiargs ret))
+ (list (append
+ '(flet ((setarg (type arg)
+ (setq ffiargs
+ (cons
+ (if (ffi-object-p arg)
+ arg
+ (ffi-create-fo type arg))
+ ffiargs)))))
+ flet-form))
+ ))))
(append '(progn) (list defun-form)
- (list `(put ',nsl 'ffi-fun
- (ffi-defun '(function ,ret-type ,@at) ,nsf))))))
+ (list `(put ',nsl 'ffi-fun
+ (ffi-defun '(function ,ret-type ,@at) ,nsf))))))
(put 'cffi:defcfun 'lisp-indent-function 'defun)
may be stack-allocated if supported by the implementation. If
SIZE-VAR is supplied, it will be bound to SIZE during BODY."
(let ((var (car spec))
- (size (cadr spec))
- (size-var (caddr spec)))
+ (size (cadr spec))
+ (size-var (caddr spec)))
(unless size-var
(setf size-var (gensym "SIZE")))
`(let* ((,size-var ,size)
- (,var (cffi:foreign-alloc ,size-var)))
+ (,var (cffi:foreign-alloc ,size-var)))
(unwind-protect
- (progn ,@body)
- (cffi:foreign-free ,var)))))
+ (progn ,@body)
+ (cffi:foreign-free ,var)))))
;;;# Misc. Pointer Operations
"Return non-nil if ffi objct FO has pointer type."
(let ((ctype (ffi-canonicalise-type (ffi-object-type fo))))
(or (eq ctype 'pointer)
- (and (listp ctype)
- (eq (car ctype) 'pointer)
- (ffi-type-p (cadr ctype))))))
+ (and (listp ctype)
+ (eq (car ctype) 'pointer)
+ (ffi-type-p (cadr ctype))))))
(defalias 'cffi:make-pointer 'ffi-make-pointer)
(defalias 'ffi-pointer-address 'ffi-object-address)
:fstream ffi-fo - a file descriptor to which output is redirected."
(while options
(let ((option (car options))
- (value (cadr options))
- error)
+ (value (cadr options))
+ error)
;; Handle special cases in options
(case option
- ((:url :post-fields)
- (unless (stringp value)
- (error 'invalid-argument
- "curl:easy-setopt invalid option value(must be string)"
- option value))
- (setq value (ffi-create-fo 'c-string value))
- ;; Keep reference to value until context is destroyed
- (push value (get ctx 'saved-values)))
+ ((:url :post-fields)
+ (unless (stringp value)
+ (error 'invalid-argument
+ "curl:easy-setopt invalid option value(must be string)"
+ option value))
+ (setq value (ffi-create-fo 'c-string value))
+ ;; Keep reference to value until context is destroyed
+ (push value (get ctx 'saved-values)))
- ((:read-function :write-function)
- (setq value (ffi-callback-fo value)))
+ ((:read-function :write-function)
+ (setq value (ffi-callback-fo value)))
- ((:nobody :header :post :nosignal)
- (setq value (ffi-create-fo 'int (if value 1 0)))))
+ ((:nobody :header :post :nosignal)
+ (setq value (ffi-create-fo 'int (if value 1 0)))))
(setq error (curl:curl_easy_setopt ctx option value))
(unless (zerop error)
- (error 'invalid-operation "curl:easy-setopt error" error))
+ (error 'invalid-operation "curl:easy-setopt error" error))
(setq options (cddr options)))))
(let ((err (curl:curl_easy_perform ctx)))
(unless (zerop err)
(error 'invalid-operation "curl:easy-perform error"
- (cdr (assq err curl:errors-alist))))
+ (cdr (assq err curl:errors-alist))))
err))
(defun curl:easy-perform& (ctx sentinel fs)
(if (featurep 'workers)
(let* ((job (ffi-call-function&
(get 'curl:curl_easy_perform 'ffi-fun)
- ctx sentinel fs ctx)))
+ ctx sentinel fs ctx)))
;; add ctx to plist of job
(put job 'ctx ctx)
job)
(defun curl:easy-getinfo (ctx what)
"Get info from the context CTX about WHAT."
(let* ((ival (cdr (assq what (ffi-enum-values 'curl-info))))
- (itype (if (not (numberp ival))
- (error "Unsupported info" what)
- (ecase (lsh (logand #xf00000 ival) -20)
- (1 'c-string) (2 'long) (3 'double))))
- (retfo (make-ffi-object itype)))
+ (itype (if (not (numberp ival))
+ (error "Unsupported info" what)
+ (ecase (lsh (logand #xf00000 ival) -20)
+ (1 'c-string) (2 'long) (3 'double))))
+ (retfo (make-ffi-object itype)))
(unless (zerop (curl:curl_easy_getinfo
- ctx what (ffi-address-of retfo)))
+ ctx what (ffi-address-of retfo)))
(error 'invalid-operation "curl:easy-getinfo error"))
(ffi-get retfo)))
((ptr pointer) (size int) (nmemb int) (stream pointer))
"Writer to STREAM buffer."
(let ((buf (ffi-pointer-to-lisp-object stream))
- (rsz (* size nmemb)))
+ (rsz (* size nmemb)))
(when (and (positivep rsz) (buffer-live-p buf))
(with-current-buffer buf
- (insert (ffi-get ptr :type (cons 'c-data rsz)))))
+ (insert (ffi-get ptr :type (cons 'c-data rsz)))))
rsz))
;;;###autoload
(when current-prefix-arg
;; In case of C-u
(and (y-or-n-p (format "Only download %s's HTTP header? "
- (file-basename file-or-buffer)))
- (setq options (list :header t :nobody t))))
+ (file-basename file-or-buffer)))
+ (setq options (list :header t :nobody t))))
(let* ((ctx (curl:easy-init))
- (bufferp (bufferp file-or-buffer))
- (fs (if bufferp
- (ffi-lisp-object-to-pointer file-or-buffer)
- (c:fopen (expand-file-name file-or-buffer) "w"))))
+ (bufferp (bufferp file-or-buffer))
+ (fs (if bufferp
+ (ffi-lisp-object-to-pointer file-or-buffer)
+ (c:fopen (expand-file-name file-or-buffer) "w"))))
(unwind-protect
- (progn
- (when bufferp
- (curl:easy-setopt ctx :write-function 'curl:cb-write-to-buffer))
+ (progn
+ (when bufferp
+ (curl:easy-setopt ctx :write-function 'curl:cb-write-to-buffer))
- ;; Avoid signalling!
- (curl:easy-setopt ctx :nosignal t)
+ ;; Avoid signalling!
+ (curl:easy-setopt ctx :nosignal t)
- (apply #'curl:easy-setopt ctx :fstream fs :url url options)
- (curl:easy-perform ctx))
+ (apply #'curl:easy-setopt ctx :fstream fs :url url options)
+ (curl:easy-perform ctx))
(unless bufferp (c:fclose fs))
(curl:easy-cleanup ctx))))
(temp-directory)))))
(when current-prefix-arg
(and (y-or-n-p (format "Only download %s's HTTP header? "
- (file-basename file-or-buffer)))
- (setq options (list :header t :nobody t))))
+ (file-basename file-or-buffer)))
+ (setq options (list :header t :nobody t))))
(if (featurep 'workers)
(let* ((ctx (curl:easy-init))
- (bufferp (bufferp file-or-buffer))
- (fs (if bufferp
- (ffi-lisp-object-to-pointer file-or-buffer)
- (c:fopen (expand-file-name file-or-buffer) "w"))))
- (condition-case cerr
- (progn
- (when bufferp
- (curl:easy-setopt ctx :write-function 'curl:cb-write-to-buffer))
-
- ;; Avoid signalling!
- (curl:easy-setopt ctx :nosignal t)
-
- (apply #'curl:easy-setopt ctx :fstream fs :url url options)
- (curl:easy-perform& ctx #'curl:easy-perform-sentinel
- (cons bufferp fs)))
-
- ;; Close FS, cleanup CTX and resignal error
- (t (unless bufferp (c:fclose fs))
- (curl:easy-cleanup ctx)
- (signal (car cerr) (cdr cerr)))))
+ (bufferp (bufferp file-or-buffer))
+ (fs (if bufferp
+ (ffi-lisp-object-to-pointer file-or-buffer)
+ (c:fopen (expand-file-name file-or-buffer) "w"))))
+ (condition-case cerr
+ (progn
+ (when bufferp
+ (curl:easy-setopt ctx :write-function 'curl:cb-write-to-buffer))
+
+ ;; Avoid signalling!
+ (curl:easy-setopt ctx :nosignal t)
+
+ (apply #'curl:easy-setopt ctx :fstream fs :url url options)
+ (curl:easy-perform& ctx #'curl:easy-perform-sentinel
+ (cons bufferp fs)))
+
+ ;; Close FS, cleanup CTX and resignal error
+ (t (unless bufferp (c:fclose fs))
+ (curl:easy-cleanup ctx)
+ (signal (car cerr) (cdr cerr)))))
(error 'unimplemented "Asynchronous Event Queues")))
;;;###autoload
(dummy4 :pointer))
(cffi:defcfun ("dbus_connection_send_with_reply_and_block"
- dbus:connection-send-with-reply-and-block) :pointer
+ dbus:connection-send-with-reply-and-block) :pointer
(connection :pointer)
(message :pointer)
(timeout_milliseconds :int)
(serial :pointer))
(cffi:defcfun ("dbus_connection_read_write"
- dbus:connection-read-write) dbus-bool
+ dbus:connection-read-write) dbus-bool
(connection :pointer)
(timeout-milliseconds :int))
(cffi:defcfun ("dbus_connection_read_write_dispatch"
- dbus:connection-read-write-dispatch) dbus-bool
+ dbus:connection-read-write-dispatch) dbus-bool
(connection :pointer)
(timeout-milliseconds :int))
(cffi:defcfun ("dbus_connection_pop_message"
- dbus:connection-pop-message) :pointer
+ dbus:connection-pop-message) :pointer
(connection :pointer))
(cffi:defcfun ("dbus_connection_flush" dbus:connection-flush) :void
(connection :pointer))
(cffi:defcfun ("dbus_connection_register_object_path"
- dbus:connection-register-object-path) dbus-bool
+ dbus:connection-register-object-path) dbus-bool
(connection :pointer)
(path :string)
(vtable :pointer)
;;{{{ Message functions
(cffi:defcfun ("dbus_message_new_method_call"
- dbus:message-new-method-call) :pointer
+ dbus:message-new-method-call) :pointer
(destination :string)
(path :string)
(interface :string)
&rest)
(cffi:defcfun ("dbus_message_append_args"
- dbus:message-append-args) dbus-bool
+ dbus:message-append-args) dbus-bool
(message :pointer)
(first-arg-type :int)
&rest)
(cffi:defcfun ("dbus_message_get_interface"
- dbus:message-get-interface) :string
+ dbus:message-get-interface) :string
(message :pointer))
(cffi:defcfun ("dbus_message_get_member"
- dbus:message-get-member) :string
+ dbus:message-get-member) :string
(message :pointer))
(cffi:defcfun ("dbus_message_get_path"
- dbus:message-get-path) :string
+ dbus:message-get-path) :string
(message :pointer))
(cffi:defcfun ("dbus_message_unref" dbus:message-unref) :void
(message :pointer))
(cffi:defcfun ("dbus_message_is_method_call"
- dbus:message-is-method-call) dbus-bool
+ dbus:message-is-method-call) dbus-bool
(message :pointer)
(interface :string)
(method :string))
(cffi:defcfun ("dbus_message_iter_init"
- dbus:message-iter-init) dbus-bool
+ dbus:message-iter-init) dbus-bool
(message :pointer)
(iter :pointer))
(cffi:defcfun ("dbus_message_iter_get_arg_type"
- dbus:message-iter-get-arg-type) :int
+ dbus:message-iter-get-arg-type) :int
(iter :pointer))
(cffi:defcfun ("dbus_message_iter_get_basic"
- dbus:message-iter-get-basic) :void
+ dbus:message-iter-get-basic) :void
(iter :pointer)
(value :pointer))
(cffi:defcfun ("dbus_message_new_method_return"
- dbus:message-new-method-return) :pointer
+ dbus:message-new-method-return) :pointer
(method_call :pointer))
(cffi:defcfun ("dbus_message_iter_init_append"
- dbus:message-iter-init-append) :void
+ dbus:message-iter-init-append) :void
(message :pointer)
(iter :pointer))
(cffi:defcfun ("dbus_message_iter_append_basic"
- dbus:message-iter-append-basic) dbus-bool
+ dbus:message-iter-append-basic) dbus-bool
(iter :pointer)
(type :int)
(value :pointer))
;;; TODO: elisp-friendly d-bus implementation.
;; - Use macros, like python-dbus uses its decorators
(defstruct (dbus-connection (:type vector) :named
- (:print-function
- (lambda (dc s pl)
+ (:print-function
+ (lambda (dc s pl)
(setq pl pl) ; steenkin byte-compiler! --SY.
(princ (format "#<dbus connection: %s>"
(dbus-connection-object dc)) s))))
"Create connection to D-Bus.
Return newly created connection structure."
(let ((dcon (make-dbus-connection :bus-name bus-name
- :object object-path)))
+ :object object-path)))
(setf (dbus-connection-ffi-error dcon)
- (cffi:foreign-alloc 'dbus-error))
+ (cffi:foreign-alloc 'dbus-error))
(dbus:error-init (dbus-connection-ffi-error dcon))
(setf (dbus-connection-ffi-conn dcon)
- (dbus:bus-get DBUS_BUS_SESSION
- (dbus-connection-ffi-error dcon)))
+ (dbus:bus-get DBUS_BUS_SESSION
+ (dbus-connection-ffi-error dcon)))
dcon))
(defmacro* define-dbus-signal (dcon iface signature &rest body)
(defconst gcry:md_open
(ffi-defun '(function int (pointer gcry_md_hd_t) int unsigned-int)
- "gcry_md_open")
+ "gcry_md_open")
"Return a handle for message digests.")
;;;###autoload
(defun gcry:md-open (&optional hash-algo)
"Return a message digest handle, initialised by HASH-ALGO."
(let ((md-handle (make-ffi-object '(pointer void)))
- (md-number (if hash-algo
- (gcry:md-map-name hash-algo)
- 0)))
+ (md-number (if hash-algo
+ (gcry:md-map-name hash-algo)
+ 0)))
(let ((g-hd (ffi-address-of md-handle))
- (g-algo (ffi-create-fo 'int md-number))
- (g-flags (gcry:md_flags 'gcry:md_flag_empty)))
+ (g-algo (ffi-create-fo 'int md-number))
+ (g-flags (gcry:md_flags 'gcry:md_flag_empty)))
(let ((ret (ffi-get
- (ffi-call-function gcry:md_open g-hd g-algo g-flags)))
- (hd (ffi-get g-hd)))
- (when (ffi-null-p hd)
- (error "gcry:md-open: Cannot get initial MD handle"))
- (and (zerop ret)
- (ffi-set-object-type md-handle 'gcry_md_hd_t)
- md-handle)))))
+ (ffi-call-function gcry:md_open g-hd g-algo g-flags)))
+ (hd (ffi-get g-hd)))
+ (when (ffi-null-p hd)
+ (error "gcry:md-open: Cannot get initial MD handle"))
+ (and (zerop ret)
+ (ffi-set-object-type md-handle 'gcry_md_hd_t)
+ md-handle)))))
(defalias 'gcry:make-message-digest #'gcry:md-open)
(defconst gcry:md_close
(ffi-defun '(function void gcry_md_hd_t)
- "gcry_md_close")
+ "gcry_md_close")
"Destroy a handle for message digests.")
(defmacro gcry:md-close (md-handle)
(defconst gcry:md_enable
(ffi-defun '(function int gcry_md_hd_t int)
- "gcry_md_enable")
+ "gcry_md_enable")
"Enable hash-algorithm within a message digest context.")
(defun gcry:md-enable (md-handle hash-algo)
(let ((g-algo (ffi-create-fo 'int (gcry:md-map-name hash-algo))))
(when (ffi-object-p md-handle)
(let ((ret (ffi-get
- (ffi-call-function gcry:md_enable md-handle g-algo))))
- (zerop ret)))))
+ (ffi-call-function gcry:md_enable md-handle g-algo))))
+ (zerop ret)))))
(defconst gcry:md_map_name
(ffi-defun '(function int (pointer char))
- "gcry_md_map_name")
+ "gcry_md_map_name")
"Return the enumeration value of a hash algorithm.")
(defun gcry:md-map-name (string)
(defconst gcry:md_write
(ffi-defun '(function void gcry_md_hd_t (pointer void) unsigned-int)
- "gcry_md_write")
+ "gcry_md_write")
"Write data into message digest context.")
(defun gcry:md-write (md-handle data)
"Write DATA to the digest machinery specified by MD-HANDLE."
(let ((g-buffer (ffi-create-fo 'c-data data))
- (g-length (ffi-create-fo 'unsigned-int (length data))))
+ (g-length (ffi-create-fo 'unsigned-int (length data))))
(when (ffi-object-p md-handle)
(ffi-call-function gcry:md_write md-handle g-buffer g-length)
t)))
(defconst gcry:md_get_algo_dlen
(ffi-defun '(function unsigned-int int)
- "gcry_md_get_algo_dlen")
+ "gcry_md_get_algo_dlen")
"Return the length of the message digest.")
(defun gcry:md-get-algo-dlen (hash-algo)
(defconst gcry:md_read
(ffi-defun '(function c-data gcry_md_hd_t int)
- "gcry_md_read")
+ "gcry_md_read")
"Return the message digest.")
(defun gcry:md-read (md-handle hash-algo)
(let ((g-algo (ffi-create-fo 'int (gcry:md-map-name hash-algo))))
(when (ffi-object-p md-handle)
(let ((ret (ffi-call-function gcry:md_read md-handle g-algo))
- (len (ffi-get (ffi-call-function gcry:md_get_algo_dlen g-algo))))
- ;;(ffi-get ret :type (cons 'c-data len))
- (ffi-fetch ret 0 (cons 'c-data len))))))
+ (len (ffi-get (ffi-call-function gcry:md_get_algo_dlen g-algo))))
+ ;;(ffi-get ret :type (cons 'c-data len))
+ (ffi-fetch ret 0 (cons 'c-data len))))))
;;(setq handle (gcry:md-open "SHA1"))
;;(gcry:md-enable handle "MD5")
(defconst gcry:cipher_open
(ffi-defun '(function int gcry_cipher_hd_t int int unsigned-int)
- "gcry_cipher_open")
+ "gcry_cipher_open")
"Return a handle for symmetric ciphers.")
;;;###autoload
(defun gcry:cipher-open (cipher-algo &optional mode)
"Return a symmetric cipher handle, initialised by CIPHER-ALGO."
(let ((sc-handle (make-ffi-object '(pointer void)))
- (sc-number (if cipher-algo
- (gcry:cipher-map-name cipher-algo)
- 0)))
+ (sc-number (if cipher-algo
+ (gcry:cipher-map-name cipher-algo)
+ 0)))
(when (positivep sc-number)
(let ((g-hd (ffi-address-of sc-handle))
- (g-algo (ffi-create-fo 'int sc-number))
- (g-mode (or (gcry:cipher_modes mode)
- (gcry:cipher_modes 'none)))
- (g-flags (gcry:cipher_flags 'gcry:cipher_flag_empty)))
- (let ((ret (ffi-get
- (ffi-call-function
- gcry:cipher_open g-hd g-algo g-mode g-flags)))
- (hd (ffi-get g-hd)))
- (when (ffi-null-p hd)
- (error "gcry:cipher-open: Cannot get initial cipher handle"))
- (and (zerop ret)
- (ffi-set-object-type sc-handle 'gcry_cipher_hd_t)
- (put sc-handle 'cipher-algo g-algo)
- (put sc-handle 'cipher-mode g-mode)
- sc-handle))))))
+ (g-algo (ffi-create-fo 'int sc-number))
+ (g-mode (or (gcry:cipher_modes mode)
+ (gcry:cipher_modes 'none)))
+ (g-flags (gcry:cipher_flags 'gcry:cipher_flag_empty)))
+ (let ((ret (ffi-get
+ (ffi-call-function
+ gcry:cipher_open g-hd g-algo g-mode g-flags)))
+ (hd (ffi-get g-hd)))
+ (when (ffi-null-p hd)
+ (error "gcry:cipher-open: Cannot get initial cipher handle"))
+ (and (zerop ret)
+ (ffi-set-object-type sc-handle 'gcry_cipher_hd_t)
+ (put sc-handle 'cipher-algo g-algo)
+ (put sc-handle 'cipher-mode g-mode)
+ sc-handle))))))
(defalias 'gcry:make-symmetric-cipher #'gcry:cipher-open)
(defconst gcry:cipher_close
(ffi-defun '(function void gcry_cipher_hd_t)
- "gcry_cipher_close")
+ "gcry_cipher_close")
"Destroy a handle for symmetric ciphers.")
(defmacro gcry:cipher-close (sc-handle)
(defconst gcry:cipher_map_name
(ffi-defun '(function int (pointer char))
- "gcry_cipher_map_name")
+ "gcry_cipher_map_name")
"Return the enumeration value of a cipher algorithm.")
(defun gcry:cipher-map-name (string)
(defconst gcry:cipher_ctl
(ffi-defun '(function int gcry_cipher_hd_t int (pointer void) unsigned-int)
- "gcry_cipher_ctl")
+ "gcry_cipher_ctl")
"Generic cipher accessor.")
(defun gcry:cipher-setkey (sc-handle key)
"Set the key of SC-HANDLE to KEY."
(when (and (stringp key)
- (gcry:cipher-handle-p sc-handle))
+ (gcry:cipher-handle-p sc-handle))
(let ((g-cmd (cdr (assq 'gcryctl_set_key gcry:ctl_cmds)))
- (g-buffer (ffi-create-fo 'c-string key))
- (g-nbytes (ffi-create-fo 'unsigned-int (length key))))
+ (g-buffer (ffi-create-fo 'c-string key))
+ (g-nbytes (ffi-create-fo 'unsigned-int (length key))))
(let ((ret
- (ffi-get
- (ffi-call-function gcry:cipher_ctl
- sc-handle g-cmd g-buffer g-nbytes))))
- (when (zerop ret)
- t)))))
+ (ffi-get
+ (ffi-call-function gcry:cipher_ctl
+ sc-handle g-cmd g-buffer g-nbytes))))
+ (when (zerop ret)
+ t)))))
(defun gcry:cipher-setiv (sc-handle iv)
"Set the initialisation vector of SC-HANDLE to IV."
(when (and (stringp iv)
- (gcry:cipher-handle-p sc-handle))
+ (gcry:cipher-handle-p sc-handle))
(let ((g-cmd (cdr (assq 'gcryctl_set_iv gcry:ctl_cmds)))
- (g-buffer (ffi-create-fo 'c-string iv))
- (g-nbytes (ffi-create-fo 'unsigned-int (length iv))))
+ (g-buffer (ffi-create-fo 'c-string iv))
+ (g-nbytes (ffi-create-fo 'unsigned-int (length iv))))
(let ((ret
- (ffi-get
- (ffi-call-function gcry:cipher_ctl
- sc-handle g-cmd g-buffer g-nbytes))))
- (when (zerop ret)
- t)))))
+ (ffi-get
+ (ffi-call-function gcry:cipher_ctl
+ sc-handle g-cmd g-buffer g-nbytes))))
+ (when (zerop ret)
+ t)))))
(defun gcry:padded-length (string &optional block-length)
"Return the length of STRING after correct padding to
BLOCK-LENGTH (defaults to 8)."
(let* ((blklen (or block-length 8))
- (slen (length string))
- (blks (1+ (div slen blklen)))
- (plen (* blks blklen)))
+ (slen (length string))
+ (blks (1+ (div slen blklen)))
+ (plen (* blks blklen)))
plen))
(defun gcry:padded-string (string &optional block-length)
"Return the padded version of STRING after correct padding to
BLOCK-LENGTH (defaults to 8)."
(let* ((blklen (or block-length 8))
- (padlen (gcry:padded-length string blklen))
- (strlen (length string))
- (defect (- padlen strlen))
- (pad (make-string defect defect)))
+ (padlen (gcry:padded-length string blklen))
+ (strlen (length string))
+ (defect (- padlen strlen))
+ (pad (make-string defect defect)))
(concat string pad)))
;; (setq somestring "testffff")
;; (gcry:padded-string somestring)
"Return the unpadded version of STRING assumed a correct padding has
been applied."
(let* ((strlen (length string))
- (padchr (char-to-int (aref string (1- strlen))))
- ;; validate the padding
- (first-padchr (when (and (positivep padchr)
- (<= padchr strlen))
- (char-to-int (aref string (- strlen padchr)))))
- (pad-valid-p (when first-padchr
- (= first-padchr padchr))))
+ (padchr (char-to-int (aref string (1- strlen))))
+ ;; validate the padding
+ (first-padchr (when (and (positivep padchr)
+ (<= padchr strlen))
+ (char-to-int (aref string (- strlen padchr)))))
+ (pad-valid-p (when first-padchr
+ (= first-padchr padchr))))
(when pad-valid-p
(substring string 0 (- strlen padchr)))))
;;(gcry:unpadded-string "abcd\0\0")
;; encryption/decryption routines
(defconst gcry:cipher_encrypt
(ffi-defun '(function int
- gcry_cipher_hd_t c-data unsigned-int
- c-data unsigned-int)
- "gcry_cipher_encrypt")
+ gcry_cipher_hd_t c-data unsigned-int
+ c-data unsigned-int)
+ "gcry_cipher_encrypt")
"Encrypt data under a cipher context.")
(defun gcry:cipher-encrypt (sc-handle plain)
"Encrypt PLAIN with the settings in SC-HANDLE and return the result."
(when (and (stringp plain)
- (gcry:cipher-handle-p sc-handle))
+ (gcry:cipher-handle-p sc-handle))
(let* ((blklen (gcry:cipher-get-block-length (get sc-handle 'cipher-algo)))
- ;; add openssl conform padding (gcrypt obviously does not care)
- (plain (gcry:padded-string plain blklen))
- (outlen (length plain)))
+ ;; add openssl conform padding (gcrypt obviously does not care)
+ (plain (gcry:padded-string plain blklen))
+ (outlen (length plain)))
(let ((g-in (ffi-create-fo (cons 'c-data (1+ outlen)) plain))
- (g-inlen (ffi-create-fo 'unsigned-int outlen))
- (g-out (make-ffi-object (cons 'c-data outlen)))
- (g-outlen (ffi-create-fo 'unsigned-int outlen)))
- (let ((ret
- (ffi-get
- (ffi-call-function gcry:cipher_encrypt
- sc-handle g-out g-outlen g-in g-inlen))))
- (when (zerop ret)
- (ffi-get g-out)))))))
+ (g-inlen (ffi-create-fo 'unsigned-int outlen))
+ (g-out (make-ffi-object (cons 'c-data outlen)))
+ (g-outlen (ffi-create-fo 'unsigned-int outlen)))
+ (let ((ret
+ (ffi-get
+ (ffi-call-function gcry:cipher_encrypt
+ sc-handle g-out g-outlen g-in g-inlen))))
+ (when (zerop ret)
+ (ffi-get g-out)))))))
(defconst gcry:cipher_decrypt
(ffi-defun '(function int
- gcry_cipher_hd_t c-data unsigned-int
- c-data unsigned-int)
- "gcry_cipher_decrypt")
+ gcry_cipher_hd_t c-data unsigned-int
+ c-data unsigned-int)
+ "gcry_cipher_decrypt")
"Decrypt data under a cipher context.")
(defun gcry:cipher-decrypt (sc-handle ciphered)
"Decrypt CIPHERED with the settings in SC-HANDLE and return the result."
(when (and (stringp ciphered)
- (gcry:cipher-handle-p sc-handle))
+ (gcry:cipher-handle-p sc-handle))
(let* (;;(blklen
- ;; (gcry:cipher-get-block-length (get sc-handle 'cipher-algo)))
- (outlen (length ciphered)))
+ ;; (gcry:cipher-get-block-length (get sc-handle 'cipher-algo)))
+ (outlen (length ciphered)))
(let ((g-in (ffi-create-fo 'c-data ciphered))
- (g-inlen (ffi-create-fo 'unsigned-int outlen))
- (g-out (make-ffi-object (cons 'c-data outlen)))
- (g-outlen (ffi-create-fo 'unsigned-int outlen)))
- (let ((ret
- (ffi-get
- (ffi-call-function gcry:cipher_decrypt
- sc-handle g-out g-outlen g-in g-inlen))))
- (when (zerop ret)
- (gcry:unpadded-string
- (ffi-fetch g-out 0 (cons 'c-data outlen)))))))))
+ (g-inlen (ffi-create-fo 'unsigned-int outlen))
+ (g-out (make-ffi-object (cons 'c-data outlen)))
+ (g-outlen (ffi-create-fo 'unsigned-int outlen)))
+ (let ((ret
+ (ffi-get
+ (ffi-call-function gcry:cipher_decrypt
+ sc-handle g-out g-outlen g-in g-inlen))))
+ (when (zerop ret)
+ (gcry:unpadded-string
+ (ffi-fetch g-out 0 (cons 'c-data outlen)))))))))
(defconst gcry:cipher_algo_info
(ffi-defun '(function int int int (pointer void) (pointer unsigned-int))
- "gcry_cipher_algo_info")
+ "gcry_cipher_algo_info")
"Return information generically of a cipher algorithm.")
(defun gcry:cipher-algo-info (cipher-algo which-info)
WHICH-INFO must be one of 'gcryctl_get_keylen, 'gcryctl_get_blklen and
'gcryctl_test_algo."
(when (or (eq which-info 'gcryctl_get_keylen)
- (eq which-info 'gcryctl_get_blklen)
- (eq which-info 'gcryctl_test_algo))
+ (eq which-info 'gcryctl_get_blklen)
+ (eq which-info 'gcryctl_test_algo))
(let ((g-what (cdr (assq which-info gcry:ctl_cmds)))
- (g-algo (cond ((stringp cipher-algo)
- (ffi-create-fo 'int (gcry:cipher-map-name cipher-algo)))
- ((intp cipher-algo)
- (ffi-create-fo 'int cipher-algo))
- ((and (ffi-object-p cipher-algo)
- (eq (ffi-object-type cipher-algo) 'int))
- cipher-algo)))
- (g-buffer (ffi-null-pointer))
- (g-nbytes (make-ffi-object 'unsigned-int)))
+ (g-algo (cond ((stringp cipher-algo)
+ (ffi-create-fo 'int (gcry:cipher-map-name cipher-algo)))
+ ((intp cipher-algo)
+ (ffi-create-fo 'int cipher-algo))
+ ((and (ffi-object-p cipher-algo)
+ (eq (ffi-object-type cipher-algo) 'int))
+ cipher-algo)))
+ (g-buffer (ffi-null-pointer))
+ (g-nbytes (make-ffi-object 'unsigned-int)))
(let* ((g-nbytes* (if (eq which-info 'gcryctl_test_algo)
- (ffi-null-pointer)
- (ffi-address-of g-nbytes)))
- (ret
- (ffi-get
- (ffi-call-function gcry:cipher_algo_info
- g-algo g-what g-buffer g-nbytes*))))
- (when (zerop ret)
- (if (eq which-info 'gcryctl_test_algo)
- t
- (ffi-get g-nbytes)))))))
+ (ffi-null-pointer)
+ (ffi-address-of g-nbytes)))
+ (ret
+ (ffi-get
+ (ffi-call-function gcry:cipher_algo_info
+ g-algo g-what g-buffer g-nbytes*))))
+ (when (zerop ret)
+ (if (eq which-info 'gcryctl_test_algo)
+ t
+ (ffi-get g-nbytes)))))))
;; derived funs
(defun gcry:cipher-get-key-length (cipher)
;;; Commentary:
-;;
+;;
;;; Code:
(require 'ffi)
Empty stream is returned if end-of-file indicated.
Error raises if some error occurs."
(let* ((fod (make-ffi-object (cons 'c-data size)))
- (rsz (c:fread-1 fod 1 size stream)))
+ (rsz (c:fread-1 fod 1 size stream)))
(if (zerop rsz)
- (cond ((c:feof-p stream) "")
- ((c:ferror-p stream)
- (error 'io-error "c:fread error"
- (c:strerror (ffi-get c:errno))))
- (t (error 'io-error "c:fread unknown error")))
+ (cond ((c:feof-p stream) "")
+ ((c:ferror-p stream)
+ (error 'io-error "c:fread error"
+ (c:strerror (ffi-get c:errno))))
+ (t (error 'io-error "c:fread unknown error")))
(ffi-get fod :type (cons 'c-data rsz)))))
-
+
(cffi:defcfun ("fwrite" c:fwrite-1) unsigned-int
"Elisp binding to fwrite(3).
Consider using `c:fwrite' in your programs."
sequences (Additional characters may follow these sequences.):
``r'' Open text file for reading. The stream is positioned at the
- beginning of the file.
+ beginning of the file.
``r+'' Open for reading and writing. The stream is positioned at the
- beginning of the file.
+ beginning of the file.
``w'' Truncate file to zero length or create text file for writing.
- The stream is positioned at the beginning of the file.
+ The stream is positioned at the beginning of the file.
``w+'' Open for reading and writing. The file is created if it does not
- exist, otherwise it is truncated. The stream is positioned at
- the beginning of the file.
+ exist, otherwise it is truncated. The stream is positioned at
+ the beginning of the file.
``a'' Open for writing. The file is created if it does not exist. The
- stream is positioned at the end of the file. Subsequent writes
- to the file will always end up at the then current end of file,
- irrespective of any intervening fseek(3) or similar.
+ stream is positioned at the end of the file. Subsequent writes
+ to the file will always end up at the then current end of file,
+ irrespective of any intervening fseek(3) or similar.
``a+'' Open for reading and writing. The file is created if it does not
- exist. The stream is positioned at the end of the file. Subse-
- quent writes to the file will always end up at the then current
- end of file, irrespective of any intervening fseek(3) or similar.
+ exist. The stream is positioned at the end of the file. Subse-
+ quent writes to the file will always end up at the then current
+ end of file, irrespective of any intervening fseek(3) or similar.
The mode string can also include the letter ``b'' either as a third char-
acter or as a character between the characters in any of the two-charac-
(let ((rv (c:fopen-1 file mode)))
(when (ffi-null-p rv)
(error 'file-error "c:fopen open error"
- file (c:strerror (ffi-get c:errno))))
+ file (c:strerror (ffi-get c:errno))))
rv))
(cffi:defcfun ("dup" c:dup) int
;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;; Commentary:
-;;
+;;
;; Mimic file(1)'s basic usage. At the moment, this is quite raw
;; and single-minded. It will only use the default magic db and
;; doesn't allow use of any of file(1)'s options.
(let ((ftype (magic-file ffi-magic-shared (expand-file-name file))))
(if (interactive-p)
- (message ftype)
+ (message ftype)
ftype)))
(defun magic:error (&optional magic)
;; ==> 0
;;
;; To create database in memory use (sqlite-open ":memory:")
-;;
+;;
;; Custom collations:
;;
;; (defun Nfirst-collation (s1 s2)
(bound pointer) (length int) (cleanup int))
(cffi:defcfun ("sqlite3_bind_parameter_count"
- sqlite:bind-parameter-count) int
+ sqlite:bind-parameter-count) int
(statement sqlite-statement))
(cffi:defcfun ("sqlite3_bind_parameter_index"
- sqlite:bind-parameter-index) int
+ sqlite:bind-parameter-index) int
(statement sqlite-statement) (column c-string))
(cffi:defcfun ("sqlite3_bind_parameter_name"
- sqlite:bind-parameter-name) c-string
+ sqlite:bind-parameter-name) c-string
(statement sqlite-statement)
(position int))
ERROR is message to be signaled."
(let ((tuple (cdr (assq result sqlite-error-codes))))
(cond ((and tuple (eq (first tuple) 'sqlite-error))
- (error 'sqlite-sql-error (if (equal error "not an error") "" error)
- :code 1 :name (first tuple)
- :comment (second tuple)))
- (tuple
- (error 'sqlite-error error
- :code result :name (first tuple) :comment (second tuple)))
- (t result))))
+ (error 'sqlite-sql-error (if (equal error "not an error") "" error)
+ :code 1 :name (first tuple)
+ :comment (second tuple)))
+ (tuple
+ (error 'sqlite-error error
+ :code result :name (first tuple) :comment (second tuple)))
+ (t result))))
;;}}}
;;{{{ Open/close database
"Try to open SQLite dabase stored in FILE.
On success return database object."
(let* ((db (make-ffi-object 'sqlite))
- (result (sqlite:open-internal
- (expand-file-name file) (ffi-address-of db)))
- (retdb (ffi-get db)))
+ (result (sqlite:open-internal
+ (expand-file-name file) (ffi-address-of db)))
+ (retdb (ffi-get db)))
(sqlite-check-result result (sqlite:errmsg retdb))
(push retdb sqlite-databases)
retdb))
(defun sqlite-prepare (db sql)
"For DB prepare statement for given SQL."
(let ((stat (make-ffi-object 'sqlite-statement))
- (tail (make-ffi-object 'pointer)))
+ (tail (make-ffi-object 'pointer)))
(sqlite-check-result
(sqlite:prepare db sql (length sql)
- (ffi-address-of stat)
- (ffi-address-of tail))
+ (ffi-address-of stat)
+ (ffi-address-of tail))
(sqlite:errmsg db))
(ffi-get stat)))
\(the default one\). You must know exactly what you are doing if you
provide COPY-FLAG argument."
(let ((key (if (integerp key-object)
- key-object
- (sqlite:bind-parameter-index
- statement
- (if (symbolp key-object)
- (concat ":" (symbol-name key-object))
- key-object)))))
+ key-object
+ (sqlite:bind-parameter-index
+ statement
+ (if (symbolp key-object)
+ (concat ":" (symbol-name key-object))
+ key-object)))))
(when key
(cond ((null value) (sqlite:bind-null statement key))
- ((integerp value)
- (sqlite:bind-int statement key value))
- ((floatp value)
- (sqlite:bind-double statement key value))
- ((stringp value)
- (sqlite:bind-text statement key value (length value)
- (or copy-flag sqlite-STATIC)))
- ((and (consp value) (eq (car value) 'blob)
- (stringp (cdr value)))
- (let ((bval (ffi-create-fo `(c-data . ,(length (cdr value)))
- (cdr value))))
- (sqlite:bind-blob
- statement key bval (length (cdr value))
- (or copy-flag sqlite-STATIC))))
- (t (error 'sqlite-datatype-error value
- :comment (concat "Attempt to insert data not one of "
- "integer, float, text, or blob."))))
+ ((integerp value)
+ (sqlite:bind-int statement key value))
+ ((floatp value)
+ (sqlite:bind-double statement key value))
+ ((stringp value)
+ (sqlite:bind-text statement key value (length value)
+ (or copy-flag sqlite-STATIC)))
+ ((and (consp value) (eq (car value) 'blob)
+ (stringp (cdr value)))
+ (let ((bval (ffi-create-fo `(c-data . ,(length (cdr value)))
+ (cdr value))))
+ (sqlite:bind-blob
+ statement key bval (length (cdr value))
+ (or copy-flag sqlite-STATIC))))
+ (t (error 'sqlite-datatype-error value
+ :comment (concat "Attempt to insert data not one of "
+ "integer, float, text, or blob."))))
)))
(defun sqlite-bind-seq (statement sequence)
BINDING could be plist, list or vector."
(when binding
(cond ((and (listp binding) (keywordp (car binding)))
- (sqlite-bind-plist statement binding))
- ((or (vectorp binding) (listp binding))
- (sqlite-bind-seq statement binding)))
+ (sqlite-bind-plist statement binding))
+ ((or (vectorp binding) (listp binding))
+ (sqlite-bind-seq statement binding)))
t))
(defun sqlite-fetch-column (statement index)
(2 (sqlite:column-double statement index))
(3 (sqlite:column-text statement index))
(4 (let ((blob (sqlite:column-blob statement index))
- (blen (sqlite:column-bytes statement index)))
- (ffi-get blob :type (cons 'c-data blen))))
+ (blen (sqlite:column-bytes statement index)))
+ (ffi-get blob :type (cons 'c-data blen))))
(5 nil)))
(defun sqlite-fetch (statement)
(when (= sqlite-ROW (sqlite:step statement))
(let ((cols (sqlite:column-count statement)))
(loop for i from 0 below cols
- collect (sqlite-fetch-column statement i)))))
+ collect (sqlite-fetch-column statement i)))))
(defun sqlite-reset (statement &optional clear-bindings)
"Reset STATEMENT, so it could be used again.
'immediate
Default is deffered."
(let ((ttype (multiple-value-bind (major minor sub)
- (mapcar 'string-to-int
- (split-string-by-char (sqlite:version) ?\.))
- (setq major major) ; shut up compiler
- (if (or (>= minor 0) (>= sub 8))
- (cond ((eq type 'exclusive) " exclusive ")
- ((eq type 'immediate) " immediate ")
- (t " "))
- " "))))
+ (mapcar 'string-to-int
+ (split-string-by-char (sqlite:version) ?\.))
+ (setq major major) ; shut up compiler
+ (if (or (>= minor 0) (>= sub 8))
+ (cond ((eq type 'exclusive) " exclusive ")
+ ((eq type 'immediate) " immediate ")
+ (t " "))
+ " "))))
(sqlite-execute db (concat "begin" ttype "transaction;") :begin nil)))
(defun sqlite-commit (db)
(defmacro* sqlite-with-transaction ((database &optional type) &body body)
(let ((db-err (gensym "dberror"))
- (db-obj (gensym "dbobject")))
+ (db-obj (gensym "dbobject")))
`(let ((,db-obj ,database)
- (,db-err t))
+ (,db-err t))
(sqlite-begin-transaction ,db-obj ,type)
(unwind-protect
- (prog1
- (progn ,@body)
- (setq ,db-err nil))
- (if ,db-err
- (sqlite-rollback ,db-obj)
- (sqlite-commit ,db-obj))))))
+ (prog1
+ (progn ,@body)
+ (setq ,db-err nil))
+ (if ,db-err
+ (sqlite-rollback ,db-obj)
+ (sqlite-commit ,db-obj))))))
(put 'sqlite-with-transaction 'lisp-indent-function 'defun)
;;}}}
(defmacro* sqlite-with-prep ((statement-var db sql &optional bind) &body body)
(let ((db-obj (gensym "dbobject"))
- (sql-in (gensym "sqlin"))
- (bind-in (gensym "bindin")))
+ (sql-in (gensym "sqlin"))
+ (bind-in (gensym "bindin")))
`(let* ((,db-obj ,db)
- (,sql-in ,sql)
- (,bind-in ,bind)
- (,statement-var (sqlite-prepare ,db-obj ,sql-in)))
+ (,sql-in ,sql)
+ (,bind-in ,bind)
+ (,statement-var (sqlite-prepare ,db-obj ,sql-in)))
(unwind-protect
- (progn
- (sqlite-bind ,statement-var ,bind-in)
- ,@body)
- (sqlite-flush ,statement-var)))))
+ (progn
+ (sqlite-bind ,statement-var ,bind-in)
+ ,@body)
+ (sqlite-flush ,statement-var)))))
(put 'sqlite-with-prep 'lisp-indent-function 'defun)
(defun sqlite-execute (db sql &optional bind begin)
If BEGIN is given, then perform a transaction."
(if begin
(sqlite-with-transaction (db)
- (sqlite-with-prep (st db sql bind)
- (sqlite-check-result (sqlite:step st) (sqlite:errmsg db))
- t))
+ (sqlite-with-prep (st db sql bind)
+ (sqlite-check-result (sqlite:step st) (sqlite:errmsg db))
+ t))
(sqlite-with-prep (st db sql bind)
(sqlite-check-result (sqlite:step st) (sqlite:errmsg db))
t)))
((user-data 'pointer) (len1 'int) (str1 'pointer)
(len2 'int) (str2 'pointer))
(let ((fun (ffi-pointer-to-lisp-object user-data))
- (s1 (ffi-get str1 :type (cons 'c-data len1)))
- (s2 (ffi-get str2 :type (cons 'c-data len2))))
+ (s1 (ffi-get str1 :type (cons 'c-data len1)))
+ (s2 (ffi-get str2 :type (cons 'c-data len2))))
(funcall fun s1 s2)))
(defun sqlite-create-collation (db name compare-function)
0 if strings are equal
1 if first string is greater then second"
(let* ((ccolls (get db 'custom-collations))
- (colla (assoc name ccolls)))
+ (colla (assoc name ccolls)))
(if colla
- (setcdr colla compare-function)
+ (setcdr colla compare-function)
(put db 'custom-collations
- (cons (cons name compare-function) ccolls))))
+ (cons (cons name compare-function) ccolls))))
(sqlite-check-result
(sqlite:create-collation
db name sqlite-UTF-8
(defun sqlite-remove-collation (db name)
"For DB remove collation by NAME."
(let* ((ccolls (get db 'custom-collations))
- (colla (assoc name ccolls)))
+ (colla (assoc name ccolls)))
(when colla
(sqlite-check-result
(sqlite:create-collation
- db name sqlite-UTF-8
- (ffi-lisp-object-to-pointer (cdr colla))
- (ffi-null-pointer))
+ db name sqlite-UTF-8
+ (ffi-lisp-object-to-pointer (cdr colla))
+ (ffi-null-pointer))
(sqlite:errmsg db))
;; Remove it from custom-collations
(put db 'custom-collations (del-alist name ccolls))
t)))
;;}}}
-
+
(provide 'ffi-sqlite)
;;; ffi-sqlite.el ends here
\f
(defconst taglib:file_new
(ffi-defun '(function TagLib_File c-string)
- "taglib_file_new")
+ "taglib_file_new")
"Create and return File object.")
(defun taglib:file-new (file)
"Create and return File object."
(defconst taglib:file_free
(ffi-defun '(function void TagLib_File)
- "taglib_file_free")
+ "taglib_file_free")
"Destruct File object.")
(defun taglib:file-free (file-object)
"Destruct File object."
(defconst taglib:file_save
(ffi-defun '(function int TagLib_File)
- "taglib_file_save")
+ "taglib_file_save")
"Save tags back to File object.")
(defun taglib:file-save (file-object)
"Save tags back to File object."
;;; constructors/destructors
(defconst taglib:file_tag
(ffi-defun '(function TagLib_Tag TagLib_File)
- "taglib_file_tag")
+ "taglib_file_tag")
"Return the tag object associated with the file object.")
(defun taglib:file-tag (file-object)
"Return the tag object associated with FILE-OBJECT."
(defconst taglib:tag_free_strings
(ffi-defun '(function void)
- "taglib_tag_free_strings")
+ "taglib_tag_free_strings")
"Free strings allocated by tag lookup functions.")
(defun taglib:tag-free-strings ()
"Free strings allocated by tag lookup functions."
;; char *taglib_tag_title(const TagLib_Tag *tag);
(defconst taglib:tag_title
(ffi-defun '(function c-string TagLib_Tag)
- "taglib_tag_title")
+ "taglib_tag_title")
"Return the title associated with tag.")
(defun taglib:tag-title (tag-object)
"Return the title associated with TAG-OBJECT."
(when (ffi-object-p tag-object)
(let* ((raw
- (ffi-call-function taglib:tag_title tag-object))
- (result
- (ffi-get raw)))
+ (ffi-call-function taglib:tag_title tag-object))
+ (result
+ (ffi-get raw)))
(taglib:tag-free-strings)
(unless (zerop (length result))
- result))))
+ result))))
;; char *taglib_tag_artist(const TagLib_Tag *tag);
(defconst taglib:tag_artist
(ffi-defun '(function c-string TagLib_Tag)
- "taglib_tag_artist")
+ "taglib_tag_artist")
"Return the artist associated with tag.")
(defun taglib:tag-artist (tag-object)
"Return the artist associated with TAG-OBJECT."
(when (ffi-object-p tag-object)
(let* ((raw
- (ffi-call-function taglib:tag_artist tag-object))
- (result
- (ffi-get raw)))
+ (ffi-call-function taglib:tag_artist tag-object))
+ (result
+ (ffi-get raw)))
(taglib:tag-free-strings)
(unless (zerop (length result))
- result))))
+ result))))
;; char *taglib_tag_album(const TagLib_Tag *tag);
(defconst taglib:tag_album
(ffi-defun '(function c-string TagLib_Tag)
- "taglib_tag_album")
+ "taglib_tag_album")
"Return the album associated with tag.")
(defun taglib:tag-album (tag-object)
"Return the album associated with TAG-OBJECT."
(when (ffi-object-p tag-object)
(let* ((raw
- (ffi-call-function taglib:tag_album tag-object))
- (result
- (ffi-get raw)))
+ (ffi-call-function taglib:tag_album tag-object))
+ (result
+ (ffi-get raw)))
(taglib:tag-free-strings)
(unless (zerop (length result))
- result))))
+ result))))
;; char *taglib_tag_comment(const TagLib_Tag *tag);
(defconst taglib:tag_comment
(ffi-defun '(function c-string TagLib_Tag)
- "taglib_tag_comment")
+ "taglib_tag_comment")
"Return the comment associated with tag.")
(defun taglib:tag-comment (tag-object)
"Return the comment associated with TAG-OBJECT."
(when (ffi-object-p tag-object)
(let* ((raw
- (ffi-call-function taglib:tag_comment tag-object))
- (result
- (ffi-get raw)))
+ (ffi-call-function taglib:tag_comment tag-object))
+ (result
+ (ffi-get raw)))
(taglib:tag-free-strings)
(unless (zerop (length result))
- result))))
+ result))))
;; char *taglib_tag_genre(const TagLib_Tag *tag);
(defconst taglib:tag_genre
(ffi-defun '(function c-string TagLib_Tag)
- "taglib_tag_genre")
+ "taglib_tag_genre")
"Return the genre associated with tag.")
(defun taglib:tag-genre (tag-object)
"Return the genre associated with TAG-OBJECT."
(when (ffi-object-p tag-object)
(let* ((raw
- (ffi-call-function taglib:tag_genre tag-object))
- (result
- (ffi-get raw)))
+ (ffi-call-function taglib:tag_genre tag-object))
+ (result
+ (ffi-get raw)))
(taglib:tag-free-strings)
(unless (zerop (length result))
- result))))
+ result))))
;; unsigned int taglib_tag_year(const TagLib_Tag *tag);
(defconst taglib:tag_year
(ffi-defun '(function int TagLib_Tag)
- "taglib_tag_year")
+ "taglib_tag_year")
"Return the year associated with tag.")
(defun taglib:tag-year (tag-object)
"Return the year associated with TAG-OBJECT."
(when (ffi-object-p tag-object)
(let* ((raw
- (ffi-call-function taglib:tag_year tag-object))
- (result
- (ffi-get raw)))
+ (ffi-call-function taglib:tag_year tag-object))
+ (result
+ (ffi-get raw)))
(unless (zerop result)
- result))))
+ result))))
;; unsigned int taglib_tag_track(const TagLib_Tag *tag);
(defconst taglib:tag_track
(ffi-defun '(function int TagLib_Tag)
- "taglib_tag_track")
+ "taglib_tag_track")
"Return the track number associated with tag.")
(defun taglib:tag-track (tag-object)
"Return the track number associated with TAG-OBJECT."
(when (ffi-object-p tag-object)
(let* ((raw
- (ffi-call-function taglib:tag_track tag-object))
- (result
- (ffi-get raw)))
+ (ffi-call-function taglib:tag_track tag-object))
+ (result
+ (ffi-get raw)))
(unless (zerop result)
- result))))
+ result))))
;;; modifiers
;; void taglib_tag_set_title(TagLib_Tag *tag, const char *title);
(defconst taglib:tag_set_title
(ffi-defun '(function void TagLib_Tag c-string)
- "taglib_tag_set_title")
+ "taglib_tag_set_title")
"Set the title and associate it with tag.")
(defun taglib:tag-set-title (tag-object title)
"Set the title to TITLE and associate it with TAG-OBJECT."
(when (and (stringp title)
- (ffi-object-p tag-object))
+ (ffi-object-p tag-object))
(let ((tit (ffi-create-fo 'c-string title)))
(ffi-call-function taglib:tag_set_title tag-object tit))
t))
;; void taglib_tag_set_artist(TagLib_Tag *tag, const char *artist);
(defconst taglib:tag_set_artist
(ffi-defun '(function void TagLib_Tag c-string)
- "taglib_tag_set_artist")
+ "taglib_tag_set_artist")
"Set the artist and associate it with tag.")
(defun taglib:tag-set-artist (tag-object artist)
"Set the artist to ARTIST and associate it with TAG-OBJECT."
(when (and (stringp artist)
- (ffi-object-p tag-object))
+ (ffi-object-p tag-object))
(let ((art (ffi-create-fo 'c-string artist)))
(ffi-call-function taglib:tag_set_artist tag-object art))
t))
;; void taglib_tag_set_album(TagLib_Tag *tag, const char *album);
(defconst taglib:tag_set_album
(ffi-defun '(function void TagLib_Tag c-string)
- "taglib_tag_set_album")
+ "taglib_tag_set_album")
"Set the album and associate it with tag.")
(defun taglib:tag-set-album (tag-object album)
"Set the album to ALBUM and associate it with TAG-OBJECT."
(when (and (stringp album)
- (ffi-object-p tag-object))
+ (ffi-object-p tag-object))
(let ((alb (ffi-create-fo 'c-string album)))
(ffi-call-function taglib:tag_set_album tag-object alb))
t))
;; void taglib_tag_set_comment(TagLib_Tag *tag, const char *comment);
(defconst taglib:tag_set_comment
(ffi-defun '(function void TagLib_Tag c-string)
- "taglib_tag_set_comment")
+ "taglib_tag_set_comment")
"Set the comment and associate it with tag.")
(defun taglib:tag-set-comment (tag-object comment)
"Set the comment to COMMENT and associate it with TAG-OBJECT."
(when (and (stringp comment)
- (ffi-object-p tag-object))
+ (ffi-object-p tag-object))
(let ((com (ffi-create-fo 'c-string comment)))
(ffi-call-function taglib:tag_set_comment tag-object com))
t))
;; void taglib_tag_set_genre(TagLib_Tag *tag, const char *genre);
(defconst taglib:tag_set_genre
(ffi-defun '(function void TagLib_Tag c-string)
- "taglib_tag_set_genre")
+ "taglib_tag_set_genre")
"Set the genre and associate it with tag.")
(defun taglib:tag-set-genre (tag-object genre)
"Set the genre to GENRE and associate it with TAG-OBJECT."
(when (and (stringp genre)
- (ffi-object-p tag-object))
+ (ffi-object-p tag-object))
(let ((gen (ffi-create-fo 'c-string genre)))
(ffi-call-function taglib:tag_set_genre tag-object gen))
t))
;; void taglib_tag_set_year(TagLib_Tag *tag, unsigned int year);
(defconst taglib:tag_set_year
(ffi-defun '(function void TagLib_Tag int)
- "taglib_tag_set_year")
+ "taglib_tag_set_year")
"Set the year and associate it with tag.")
(defun taglib:tag-set-year (tag-object year)
"Set the year to YEAR and associate it with TAG-OBJECT."
(when (and (natnump year)
- (ffi-object-p tag-object))
+ (ffi-object-p tag-object))
(let ((yea (ffi-create-fo 'int year)))
(ffi-call-function taglib:tag_set_year tag-object yea))
t))
;; void taglib_tag_set_track(TagLib_Tag *tag, unsigned int track);
(defconst taglib:tag_set_track
(ffi-defun '(function void TagLib_Tag int)
- "taglib_tag_set_track")
+ "taglib_tag_set_track")
"Set the track number and associate it with tag.")
(defun taglib:tag-set-track (tag-object track)
"Set the track number to TRACK and associate it with TAG-OBJECT."
(when (and (natnump track)
- (ffi-object-p tag-object))
+ (ffi-object-p tag-object))
(let ((tra (ffi-create-fo 'int track)))
(ffi-call-function taglib:tag_set_track tag-object tra))
t))
;;; constructors
(defconst taglib:file_audioproperties
(ffi-defun '(function TagLib_AudioProperties TagLib_File)
- "taglib_file_audioproperties")
+ "taglib_file_audioproperties")
"Return the AudioProperties object associated with the file object.")
(defun taglib:file-audio-properties (file-object)
"Return the audio properties object associated with FILE-OBJECT."
(defconst taglib:audioproperties_length
(ffi-defun '(function int TagLib_AudioProperties)
- "taglib_audioproperties_length")
+ "taglib_audioproperties_length")
"Return the length of the audioproperties object in seconds.")
(defun taglib:audioproperties-length (audioprops)
"Return the length of AUDIOPROPS in seconds."
(when (ffi-object-p audioprops)
(let* ((raw
- (ffi-call-function taglib:audioproperties_length audioprops))
- (result
- (ffi-get raw)))
+ (ffi-call-function taglib:audioproperties_length audioprops))
+ (result
+ (ffi-get raw)))
(unless (zerop result)
- result))))
+ result))))
(defconst taglib:audioproperties_bitrate
(ffi-defun '(function int TagLib_AudioProperties)
- "taglib_audioproperties_bitrate")
+ "taglib_audioproperties_bitrate")
"Return the bitrate of the audioproperties object in kb/s.")
(defun taglib:audioproperties-bitrate (audioprops)
"Return the bitrate of AUDIOPROPS in kb/s (kilobit per second)."
(when (ffi-object-p audioprops)
(let* ((raw
- (ffi-call-function taglib:audioproperties_bitrate audioprops))
- (result
- (ffi-get raw)))
+ (ffi-call-function taglib:audioproperties_bitrate audioprops))
+ (result
+ (ffi-get raw)))
(unless (zerop result)
- result))))
+ result))))
(defconst taglib:audioproperties_samplerate
(ffi-defun '(function int TagLib_AudioProperties)
- "taglib_audioproperties_samplerate")
+ "taglib_audioproperties_samplerate")
"Return the samplerate of the audioproperties object in Hz.")
(defun taglib:audioproperties-samplerate (audioprops)
"Return the samplerate of AUDIOPROPS in Hz."
(when (ffi-object-p audioprops)
(let* ((raw
- (ffi-call-function taglib:audioproperties_samplerate audioprops))
- (result
- (ffi-get raw)))
+ (ffi-call-function taglib:audioproperties_samplerate audioprops))
+ (result
+ (ffi-get raw)))
(unless (zerop result)
- result))))
+ result))))
(defconst taglib:audioproperties_channels
(ffi-defun '(function int TagLib_AudioProperties)
- "taglib_audioproperties_channels")
+ "taglib_audioproperties_channels")
"Return the number of channels of the audioproperties object.")
(defun taglib:audioproperties-channels (audioprops)
"Return the number of channels of AUDIOPROPS."
(when (ffi-object-p audioprops)
(let* ((raw
- (ffi-call-function taglib:audioproperties_channels audioprops))
- (result
- (ffi-get raw)))
+ (ffi-call-function taglib:audioproperties_channels audioprops))
+ (result
+ (ffi-get raw)))
(unless (zerop result)
- result))))
+ result))))
\f
;;; higher level API
"Return an alist of available properties of FILE."
(when (file-readable-p file)
(let* ((result (dllist))
- (exp-file (expand-file-name file))
- (tlf (taglib:file-new exp-file)))
+ (exp-file (expand-file-name file))
+ (tlf (taglib:file-new exp-file)))
(when (and tlf
- (null (ffi-null-p tlf)))
- (let ((tlt (taglib:file-tag tlf))
- (tlap (taglib:file-audio-properties tlf))
- (tfuns (list
- (cons 'title #'taglib:tag-title)
- (cons 'artist #'taglib:tag-artist)
- (cons 'album #'taglib:tag-album)
- (cons 'comment #'taglib:tag-comment)
- (cons 'genre #'taglib:tag-genre)
- (cons 'year #'taglib:tag-year)
- (cons 'track #'taglib:tag-track)))
- (apfuns (list
- (cons 'length #'taglib:audioproperties-length)
- (cons 'bitrate #'taglib:audioproperties-bitrate)
- (cons 'samplerate #'taglib:audioproperties-samplerate)
- (cons 'channels #'taglib:audioproperties-channels))))
- (unless (ffi-null-p tlt)
- (mapc-internal
- #'(lambda (fun)
- (let ((res (funcall (cdr fun) tlt)))
- (when res
- (dllist-append result (cons (car fun) res)))))
- tfuns))
- (unless (ffi-null-p tlap)
- (mapc-internal
- #'(lambda (fun)
- (let ((res (funcall (cdr fun) tlap)))
- (when res
- (dllist-append result (cons (car fun) res)))))
- apfuns)
- (dllist-prepend result (cons 'type 'audio))))
- (taglib:file-free tlf)
-
- ;; prepend some generic information
- (dllist-prepend result (cons 'driver 'taglib))
- (dllist-prepend result (cons 'file exp-file))
- (dllist-prepend result (cons 'kind 'file)))
+ (null (ffi-null-p tlf)))
+ (let ((tlt (taglib:file-tag tlf))
+ (tlap (taglib:file-audio-properties tlf))
+ (tfuns (list
+ (cons 'title #'taglib:tag-title)
+ (cons 'artist #'taglib:tag-artist)
+ (cons 'album #'taglib:tag-album)
+ (cons 'comment #'taglib:tag-comment)
+ (cons 'genre #'taglib:tag-genre)
+ (cons 'year #'taglib:tag-year)
+ (cons 'track #'taglib:tag-track)))
+ (apfuns (list
+ (cons 'length #'taglib:audioproperties-length)
+ (cons 'bitrate #'taglib:audioproperties-bitrate)
+ (cons 'samplerate #'taglib:audioproperties-samplerate)
+ (cons 'channels #'taglib:audioproperties-channels))))
+ (unless (ffi-null-p tlt)
+ (mapc-internal
+ #'(lambda (fun)
+ (let ((res (funcall (cdr fun) tlt)))
+ (when res
+ (dllist-append result (cons (car fun) res)))))
+ tfuns))
+ (unless (ffi-null-p tlap)
+ (mapc-internal
+ #'(lambda (fun)
+ (let ((res (funcall (cdr fun) tlap)))
+ (when res
+ (dllist-append result (cons (car fun) res)))))
+ apfuns)
+ (dllist-prepend result (cons 'type 'audio))))
+ (taglib:file-free tlf)
+
+ ;; prepend some generic information
+ (dllist-prepend result (cons 'driver 'taglib))
+ (dllist-prepend result (cons 'file exp-file))
+ (dllist-prepend result (cons 'kind 'file)))
(dllist-to-list result))))
;; so be careful. Need some assistance from IM developers to solve
;; this problem.
;;
-;;
+;;
;;}}}
;;; Code:
\f
(eval-when-compile
(globally-declare-boundp
'(operations-list undo-list buffer-file-name image-wand preview-wand
- preview-region preview-extent
- find-file-magic-files-alist)))
+ preview-region preview-extent
+ find-file-magic-files-alist)))
(require 'ffi)
(require 'wid-edit)
(defvar Wand-ffio-as-image-data
(valid-instantiator-p
(vector 'rawrgb :data (make-ffi-object 'pointer)
- :pixel-width 2 :pixel-height 2) 'image))
+ :pixel-width 2 :pixel-height 2) 'image))
(defvar Wand-GM-p nil
"Non-nil if using GraphicsMagick.")
(or (ffi-load-library "libWand")
(ffi-load-library "libMagickWand")
(and (ffi-load "libGraphicsMagickWand")
- (setq Wand-GM-p t)))
+ (setq Wand-GM-p t)))
;;}}}
;;{{{ [+] FFI for MagickWand
"Create a string from CamelCased keyword KW.
Strips last N words."
(let ((case-fold-search nil)
- (kws (substring (symbol-name kw) 1)))
+ (kws (substring (symbol-name kw) 1)))
(while (string-match "[A-Z]" kws 1)
- (setq kws (replace-match (concat "-" (downcase (match-string 0 kws)))
- t nil kws)))
+ (setq kws (replace-match (concat "-" (downcase (match-string 0 kws)))
+ t nil kws)))
(mapconcat 'identity (butlast (split-string (downcase kws) "-") n) "-")))
(defmacro wand-camel-case-kw-completion (n)
(defconst WandCompositeOperator-completion-table
(mapcar (wand-camel-case-kw-completion 2)
- (mapcar #'car (ffi-enum-values 'WandCompositeOperator)))
+ (mapcar #'car (ffi-enum-values 'WandCompositeOperator)))
"Completion table for composite operator.")
(define-ffi-enum FillRule
(defconst MagickPreviewType-completion-table
(mapcar (wand-camel-case-kw-completion 1)
- (mapcar #'car (ffi-enum-values 'MagickPreviewType)))
+ (mapcar #'car (ffi-enum-values 'MagickPreviewType)))
"Completion table for preview types.")
;;}}}
(let ((mt (Wand:MagickToMime format)))
(unless (ffi-null-p mt)
(unwind-protect
- (ffi-get mt :type 'c-string)
- (Wand:DestroyString mt)))))
+ (ffi-get mt :type 'c-string)
+ (Wand:DestroyString mt)))))
(defun Wand:image-mime-type (wand)
"Return mime-type for the WAND."
"With allocated WAND do FORMS."
`(let ((,wand (Wand:make-wand)))
(unwind-protect
- (progn ,@forms)
+ (progn ,@forms)
(Wand:delete-wand ,wand))))
(put 'Wand-with-wand 'lisp-indent-function 'defun)
"Return info about the image stored in WAND."
(let ((ii (Wand:MagickIdentifyImage wand)))
(unwind-protect
- (ffi-get ii :type 'c-string)
+ (ffi-get ii :type 'c-string)
(Wand:RelinquishMemory ii))))
;; MagickResetImagePage() resets the Wand page canvas and position.
`directory', `extension', `height', `input', `magick', `name',
`page', `size', `width', `xresolution', `yresolution'."
(when (member prop '("group" "kurtosis" "max" "mean"
- "min" "output" "scene" "skewness"
- "standard-deviation" "standard_deviation"
- "unique" "zero"))
+ "min" "output" "scene" "skewness"
+ "standard-deviation" "standard_deviation"
+ "unique" "zero"))
(error "Unsupported magick property" prop))
(let ((rt (Wand:GetMagickProperty
- (ffi-null-pointer) (MagickWand-private->images wand)
- prop)))
+ (ffi-null-pointer) (MagickWand-private->images wand)
+ prop)))
(unless (ffi-null-p rt)
(ffi-get rt :type 'c-string))))
(defun Wand:read-image-blob (wand blob)
"Read image from BLOB and associate it with WAND."
(let* ((lb (length blob))
- (fob (make-ffi-object 'pointer (1+ lb))))
+ (fob (make-ffi-object 'pointer (1+ lb))))
(ffi-store fob 0 'c-string blob)
(Wand:MagickReadImageBlob wand fob lb)))
"Return WAND's direct image data according to format.
Use \(setf \(Wand:image-format w\) FMT\) to set format."
(let* ((len (make-ffi-object 'unsigned-int))
- (data (Wand:GetImageBlob wand (ffi-address-of len))))
+ (data (Wand:GetImageBlob wand (ffi-address-of len))))
(unwind-protect
- (ffi-get data :type (cons 'c-data (ffi-get len)))
+ (ffi-get data :type (cons 'c-data (ffi-get len)))
(Wand:RelinquishMemory data))))
(cffi:defcfun ("MagickWriteImage" Wand:MagickWriteImage) MagickBooleanType
;;{{{ `-- Image format operations
(cffi:defcfun ("MagickQueryFormats"
- Wand:QueryFormats) (pointer c-string)
- (pattern c-string)
- (num-formats (pointer unsigned-long)))
+ Wand:QueryFormats) (pointer c-string)
+ (pattern c-string)
+ (num-formats (pointer unsigned-long)))
(defun Wand:query-formats (pattern)
"Return list of supported formats that match PATTERN.
Use \"*\" to query all available formats."
(let* ((nf (make-ffi-object 'unsigned-long))
- (fmts (Wand:QueryFormats pattern (ffi-address-of nf))))
+ (fmts (Wand:QueryFormats pattern (ffi-address-of nf))))
(loop for n from 0 below (ffi-get nf)
collect (ffi-get
- (ffi-get fmts :off (* n (ffi-size-of-type 'pointer)))
- :type 'c-string))))
+ (ffi-get fmts :off (* n (ffi-size-of-type 'pointer)))
+ :type 'c-string))))
(cffi:defcfun ("MagickGetFormat" Wand:wand-format) c-string
(wand MagickWand))
"With allocated pixel wand PW do FORMS."
`(let ((,pw (Wand:NewPixelWand)))
(unwind-protect
- (progn ,@forms)
+ (progn ,@forms)
(Wand:DestroyPixelWand ,pw))))
(put 'Wand-with-pixel-wand 'lisp-indent-function 'defun)
(defun Wand:pixel-hsl (pw)
"Return HSL for pixel wand PW."
(let ((hue (make-ffi-object 'double))
- (sat (make-ffi-object 'double))
- (light (make-ffi-object 'double)))
+ (sat (make-ffi-object 'double))
+ (light (make-ffi-object 'double)))
(Wand:PixelGetHSL pw (ffi-address-of hue) (ffi-address-of sat)
- (ffi-address-of light))
+ (ffi-address-of light))
(mapcar #'ffi-get (list hue sat light))))
(defsetf Wand:pixel-hsl (pw) (hsl)
(defun Wand:pixel-rgb-components (pw)
"Return RGB components for pixel wand PW."
(mapcar #'(lambda (c) (int (* (funcall c pw) 65535.0)))
- '(Wand:pixel-red Wand:pixel-green Wand:pixel-blue)))
+ '(Wand:pixel-red Wand:pixel-green Wand:pixel-blue)))
(defsetf Wand:pixel-rgb-components (pw) (rgb)
"For pixel wand PW set RGB components."
`(mapcar* #'(lambda (sf c) (funcall sf ,pw (/ c 65535.0)))
- '(Wand:PixelSetRed Wand:PixelSetGreen Wand:PixelSetBlue)
- ,rgb))
+ '(Wand:PixelSetRed Wand:PixelSetGreen Wand:PixelSetBlue)
+ ,rgb))
;; PixelGetColorAsString() returns the color of the pixel wand as a
;; string.
FROM-WIDTH, FROM-HEIGHT, DELTA-WIDTH, DELTA-HEIGHT specifies region to
fetch data from."
(let* ((tsz (ecase img-type (rawrgb 3) (rawrgba 4)))
- (mapn (ecase img-type (rawrgb "RGB") (rawrgba "RGBA")))
- (target (make-ffi-object 'c-data (* delta-width delta-height tsz))))
+ (mapn (ecase img-type (rawrgb "RGB") (rawrgba "RGBA")))
+ (target (make-ffi-object 'c-data (* delta-width delta-height tsz))))
(when (Wand:MagickGetImagePixels
- wand from-width from-height delta-width delta-height
- mapn :char-pixel target)
+ wand from-width from-height delta-width delta-height
+ mapn :char-pixel target)
(if Wand-ffio-as-image-data
- target
- (ffi-get target)))))
+ target
+ (ffi-get target)))))
(defun Wand:get-image-pixels (wand)
"Return WAND's raw string of image pixel data (RGB triples)."
"Extract colors from SS string.
Return list of lists of N int elements representing RBG(A) values."
(let ((cls (mapcar #'char-to-int (string-to-list ss)))
- (rls nil))
+ (rls nil))
(while cls
(push (subseq cls 0 (or n 3)) rls)
(setq cls (nthcdr (or n 3) cls)))
"Create pixels string from CLS.
CLS is list of lists of N int elements representing RBG(A) values."
(mapconcat #'identity
- (mapcan #'(lambda (els)
- (mapcar #'char-to-string
- (mapcar #'int-to-char els)))
- cls)
- ""))
+ (mapcan #'(lambda (els)
+ (mapcar #'char-to-string
+ (mapcar #'int-to-char els)))
+ cls)
+ ""))
;; MagickConstituteImage() adds an image to the wand comprised of the
;; pixel data you supply. The pixel data must be in scanline order
(wand MagickWand) (brightness double) (saturation double) (hue double))
(defun* Wand:modulate-image (wand &key (brightness 100.0)
- (saturation 100.0)
- (hue 100.0))
+ (saturation 100.0)
+ (hue 100.0))
(Wand:MagickModulateImage wand brightness saturation hue))
;; Separate a two-color high contrast image.
;; Blur CHANNEL in the image associated with WAND by RADIUS
;; pixels with derivation SIGMA.
(cffi:defcfun ("MagickGaussianBlurImageChannel"
- Wand:gaussian-blur-image-channel) MagickBooleanType
- (wand MagickWand) (channel MagickChannelType)
- (radius double) (sigma double))
+ Wand:gaussian-blur-image-channel) MagickBooleanType
+ (wand MagickWand) (channel MagickChannelType)
+ (radius double) (sigma double))
;; Blur the image associated with WAND.
;; The RADIUS argument is a float and measured in pixels.
;; defined by RADIUS and SIGMA. The strength of sharpening is controlled
;; by AMOUNT and THRESHOLD.
(cffi:defcfun ("MagickUnsharpMaskImageChannel"
- Wand:unsharp-mask-image-channel)
+ Wand:unsharp-mask-image-channel)
MagickBooleanType
(wand MagickWand) (channel MagickChannelType)
(radius double) (sigma double) (amount double) (threshold double))
(Wand:MagickNegateImage wand greyp))
(cffi:defcfun ("MagickNegateImageChannel"
- Wand:MagickNegateImageChannel)
+ Wand:MagickNegateImageChannel)
MagickBooleanType
(wand MagickWand) (channel MagickChannelType) (greyp MagickBooleanType))
(defun Wand:negate-image-channel (wand channel &optional greyp)
(defun Wand:image-size (wand)
"Return size of the image, associated with WAND."
(let ((w (make-ffi-object 'unsigned-long))
- (h (make-ffi-object 'unsigned-long)))
+ (h (make-ffi-object 'unsigned-long)))
(when (Wand:MagickGetSize wand (ffi-address-of w) (ffi-address-of h))
(cons (ffi-get w) (ffi-get h)))))
(defsetf Wand:image-size (wand) (size)
"Fetch strings from strings array STRS of length SLEN."
(unless (ffi-null-p strs)
(unwind-protect
- (mapcar #'(lambda (pr)
- (ffi-get pr :type 'c-string))
- (ffi-get strs :type (list 'array 'pointer slen)))
+ (mapcar #'(lambda (pr)
+ (ffi-get pr :type 'c-string))
+ (ffi-get strs :type (list 'array 'pointer slen)))
(Wand:RelinquishMemory strs))))
;; Profiles
(defun Wand:image-profiles (wand pattern)
"Get list of WAND's profiles matching PATTERN."
(let* ((plen (make-ffi-object 'unsigned-long))
- (profs (Wand:MagickGetImageProfiles
- wand pattern (ffi-address-of plen))))
+ (profs (Wand:MagickGetImageProfiles
+ wand pattern (ffi-address-of plen))))
(Wand-fetch-relinquish-strings profs (ffi-get plen))))
(cffi:defcfun ("MagickGetImageProfile" Wand:MagickGetImageProfile) pointer
(defun Wand:image-profile-iptc (wand)
"Fetch IPTC profile from WAND in lisp-friendly form."
(let* ((plen (make-ffi-object 'unsigned-int))
- (prof (Wand:MagickGetImageProfile wand "iptc" (ffi-address-of plen)))
- (rlen (ffi-get plen)) (coff 0) (rv nil))
+ (prof (Wand:MagickGetImageProfile wand "iptc" (ffi-address-of plen)))
+ (rlen (ffi-get plen)) (coff 0) (rv nil))
(unless (ffi-null-p prof)
(unwind-protect
- (flet ((getbyte () (prog1
- (ffi-get prof :off coff :type 'byte)
- (incf coff))))
- ;; 28 - must start any iptc header
- (while (and (< coff rlen) (= (getbyte) 28))
- (let* ((itype (getbyte)) (idset (getbyte))
- (l1 (getbyte)) (l2 (getbyte))
- (ln (logior (ash l1 8) l2)))
- (when (= itype 2)
- ;; only string type supported
- (push (cons (cdr (assq idset Wand-iptc-names-table))
- (ffi-get prof :off coff :type `(c-data . ,ln)))
- rv))
- (incf coff ln)))
- rv)
- (Wand:RelinquishMemory prof)))))
+ (flet ((getbyte () (prog1
+ (ffi-get prof :off coff :type 'byte)
+ (incf coff))))
+ ;; 28 - must start any iptc header
+ (while (and (< coff rlen) (= (getbyte) 28))
+ (let* ((itype (getbyte)) (idset (getbyte))
+ (l1 (getbyte)) (l2 (getbyte))
+ (ln (logior (ash l1 8) l2)))
+ (when (= itype 2)
+ ;; only string type supported
+ (push (cons (cdr (assq idset Wand-iptc-names-table))
+ (ffi-get prof :off coff :type `(c-data . ,ln)))
+ rv))
+ (incf coff ln)))
+ rv)
+ (Wand:RelinquishMemory prof)))))
(defun Wand:image-save-iptc-profile (w iptc)
"For wand W store IPTC profile."
(let ((oolen (reduce #'(lambda (e1 e2)
- (+ e1 5 (length (cdr e2))))
- iptc :initial-value 0)))
+ (+ e1 5 (length (cdr e2))))
+ iptc :initial-value 0)))
(when (> oolen 0)
(let ((prof (make-ffi-object 'pointer oolen))
- (coff 0))
- (flet ((savebyte (byte)
- (prog1
- (ffi-store prof coff 'byte byte)
- (incf coff))))
- (loop for ipel in iptc do
- (savebyte 28) (savebyte 2)
- (savebyte (car (find (car ipel)
- Wand-iptc-names-table :key #'cdr)))
- (let* ((ln (length (cdr ipel)))
- (l1 (ash (logand ln #xff00) -8))
- (l2 (logand ln #x00ff)))
- (savebyte l1) (savebyte l2)
- (ffi-store prof coff 'c-string (cdr ipel))
- (incf coff ln))))
- (Wand:MagickSetImageProfile w "iptc" prof oolen)))
+ (coff 0))
+ (flet ((savebyte (byte)
+ (prog1
+ (ffi-store prof coff 'byte byte)
+ (incf coff))))
+ (loop for ipel in iptc do
+ (savebyte 28) (savebyte 2)
+ (savebyte (car (find (car ipel)
+ Wand-iptc-names-table :key #'cdr)))
+ (let* ((ln (length (cdr ipel)))
+ (l1 (ash (logand ln #xff00) -8))
+ (l2 (logand ln #x00ff)))
+ (savebyte l1) (savebyte l2)
+ (ffi-store prof coff 'c-string (cdr ipel))
+ (incf coff ln))))
+ (Wand:MagickSetImageProfile w "iptc" prof oolen)))
))
;;}}}
(defun Wand:image-properties (w pattern)
"Return list of image properties that match PATTERN."
(let* ((plen (make-ffi-object 'unsigned-long))
- (props (Wand:MagickGetImageProperties
- w pattern (ffi-address-of plen))))
+ (props (Wand:MagickGetImageProperties
+ w pattern (ffi-address-of plen))))
(Wand-fetch-relinquish-strings props (ffi-get plen))))
(cffi:defcfun ("MagickGetImageProperty" Wand:MagickGetImageProperty) pointer
(let ((pv (Wand:MagickGetImageProperty w property)))
(unless (ffi-null-p pv)
(unwind-protect
- (ffi-get pv :type 'c-string)
- (Wand:RelinquishMemory pv)))))
+ (ffi-get pv :type 'c-string)
+ (Wand:RelinquishMemory pv)))))
(defsetf Wand:image-property (w prop) (val)
`(Wand:MagickSetImageProperty ,w ,prop ,val))
"Run properties editor."
(interactive)
(let* ((iw image-wand)
- (props (remove-if-not
- #'(lambda (prop)
- (string-match Wand-mode-properties-pattern prop))
- (Wand:image-properties iw ""))))
+ (props (remove-if-not
+ #'(lambda (prop)
+ (string-match Wand-mode-properties-pattern prop))
+ (Wand:image-properties iw ""))))
(save-window-excursion
(with-temp-buffer
- (save-excursion
- (mapc #'(lambda (prop)
- (insert prop ": " (Wand:image-property iw prop) "\n"))
- props))
- (pop-to-buffer (current-buffer))
- (text-mode)
- (message "Press %s when done, or %s to cancel"
- (sorted-key-descriptions
- (where-is-internal 'exit-recursive-edit))
- (sorted-key-descriptions
- (where-is-internal 'abort-recursive-edit)))
- (recursive-edit)
-
- ;; User pressed C-M-c, parse buffer and store new props
- (goto-char (point-min))
- (while (not (eobp))
- (let* ((st (buffer-substring (point-at-bol) (point-at-eol)))
- (pv (split-string st ": ")))
- (setf (Wand:image-property iw (first pv)) (second pv)))
- (next-line 1))))))
+ (save-excursion
+ (mapc #'(lambda (prop)
+ (insert prop ": " (Wand:image-property iw prop) "\n"))
+ props))
+ (pop-to-buffer (current-buffer))
+ (text-mode)
+ (message "Press %s when done, or %s to cancel"
+ (sorted-key-descriptions
+ (where-is-internal 'exit-recursive-edit))
+ (sorted-key-descriptions
+ (where-is-internal 'abort-recursive-edit)))
+ (recursive-edit)
+
+ ;; User pressed C-M-c, parse buffer and store new props
+ (goto-char (point-min))
+ (while (not (eobp))
+ (let* ((st (buffer-substring (point-at-bol) (point-at-eol)))
+ (pv (split-string st ": ")))
+ (setf (Wand:image-property iw (first pv)) (second pv)))
+ (next-line 1))))))
;;}}}
;;{{{ `-- Image clip mask
"With allocated drawing wand DW do FORMS."
`(let ((,dw (Wand:make-drawing-wand)))
(unwind-protect
- (progn ,@forms)
+ (progn ,@forms)
(Wand:delete-drawing-wand ,dw))))
(put 'Wand-with-drawing-wand 'lisp-indent-function 'defun)
(defun Wand:draw-font (dw)
"For drawing wand DW return draw font as wand-font object."
(make-wand-font :family (Wand:draw-font-family dw)
- :size (Wand:draw-font-size dw)
- :weight (Wand:draw-font-weight dw)
- :stretch (Wand:draw-font-stretch dw)
- :style (Wand:draw-font-style dw)))
+ :size (Wand:draw-font-size dw)
+ :weight (Wand:draw-font-weight dw)
+ :stretch (Wand:draw-font-stretch dw)
+ :style (Wand:draw-font-style dw)))
(defsetf Wand:draw-font (dw) (fn)
"For drawing wand DW set font to FN.
`(if (stringp ,fn)
(setf (Wand:draw-font-font ,dw) ,fn)
(let ((fm (wand-font-family ,fn))
- (sz (wand-font-size ,fn))
- (weight (wand-font-weight ,fn))
- (stretch (wand-font-stretch ,fn))
- (style (wand-font-style ,fn)))
+ (sz (wand-font-size ,fn))
+ (weight (wand-font-weight ,fn))
+ (stretch (wand-font-stretch ,fn))
+ (style (wand-font-style ,fn)))
(when fm (setf (Wand:draw-font-family ,dw) fm))
(when sz (setf (Wand:draw-font-size ,dw) sz))
(when weight (setf (Wand:draw-font-weight ,dw) weight))
(defun Wand:points-PointInfo (points)
(let* ((plen (length points))
- (coords (make-ffi-object (list 'array 'PointInfo plen))))
+ (coords (make-ffi-object (list 'array 'PointInfo plen))))
(dotimes (n plen)
(let ((poi (make-ffi-object 'PointInfo))
- (npo (nth n points)))
- (setf (PointInfo->x poi) (float (car npo))
- (PointInfo->y poi) (float (cdr npo)))
- (ffi-aset coords n poi)))
+ (npo (nth n points)))
+ (setf (PointInfo->x poi) (float (car npo))
+ (PointInfo->y poi) (float (cdr npo)))
+ (ffi-aset coords n poi)))
coords))
(defun Wand:draw-polygon (dw points)
(defun Wand:draw-segment (dw seg)
(Wand:draw-line dw (float (caar seg)) (float (cdar seg))
- (float (cadr seg)) (float (cddr seg))))
+ (float (cadr seg)) (float (cddr seg))))
(defun Wand:draw-segments (dw segs)
(mapc #'(lambda (seg) (Wand:draw-segment dw seg)) segs))
(defun Wand:emacs-image-internal (wand img-type x y w h)
"Return Emacs image spec."
(vector img-type
- :data (Wand:get-image-pixels-internal wand img-type x y w h)
- :pixel-width w
- :pixel-height h))
+ :data (Wand:get-image-pixels-internal wand img-type x y w h)
+ :pixel-width w
+ :pixel-height h))
(defun Wand:emacs-image (wand)
"Return Emacs image for the WAND."
(defun Wand:correct-orientation (wand)
"Automatically rotate WAND image according to exif:Orientation."
(let* ((orient (Wand:image-property wand "exif:Orientation"))
- (angle (cond ((string= orient "6") 90)
- ((string= orient "3") 180)
- ((string= orient "8") -90))))
+ (angle (cond ((string= orient "6") 90)
+ ((string= orient "3") 180)
+ ((string= orient "8") -90))))
(when angle
(setf (Wand:image-property wand "exif:Orientation") "1")
(Wand-operation-apply 'rotate wand angle))))
Return non-nil if fiting was performed."
(unless scaler (setq scaler #'Wand:scale-image))
(let* ((width (Wand:image-width wand))
- (height (Wand:image-height wand))
- (prop (/ (float width) (float height)))
- rescale)
+ (height (Wand:image-height wand))
+ (prop (/ (float width) (float height)))
+ rescale)
(when (or force (< max-width width))
(setq width max-width
- height (round (/ max-width prop))
- rescale t))
+ height (round (/ max-width prop))
+ rescale t))
(when (or force (< max-height height))
(setq width (round (* max-height prop))
- height max-height
- rescale t))
+ height max-height
+ rescale t))
(when rescale
(funcall scaler wand width height))
(defun Wand-mode-preview-glyph (wand)
(let ((off-x (get wand 'offset-x))
- (off-y (get wand 'offset-y)))
+ (off-y (get wand 'offset-y)))
(Wand:glyph-internal
wand off-x off-y
(- (Wand:image-width wand) off-x)
"---"
("Region" :filter Wand-menu-region-operations)
("Transform" :filter (lambda (not-used)
- (Wand-menu-generate 'transform-operation)))
+ (Wand-menu-generate 'transform-operation)))
("Effects" :filter (lambda (not-used)
- (Wand-menu-generate 'effect-operation)))
+ (Wand-menu-generate 'effect-operation)))
("Enhance" :filter (lambda (not-used)
- (Wand-menu-generate 'enhance-operation)))
+ (Wand-menu-generate 'enhance-operation)))
("F/X" :filter (lambda (not-used)
- (Wand-menu-generate 'f/x-operation)))
+ (Wand-menu-generate 'f/x-operation)))
"---"
["Quit" Wand-mode-quit])
"Menu for Wand display mode.")
(defun Wand-menu-page-navigations (not-used)
"Generate menu for page navigation."
(list ["Next Page" Wand-mode-next-page
- :active (Wand:has-next-image image-wand)]
- ["Previous Page" Wand-mode-prev-page
- :active (Wand:has-prev-image image-wand)]
- ["First Page" Wand-mode-first-page
- :active (/= (Wand:iterator-index image-wand) 0) ]
- ["Last Page" Wand-mode-last-page
- :active (/= (Wand:iterator-index image-wand)
- (1- (Wand:images-num image-wand))) ]
- "-"
- ["Goto Page" Wand-mode-goto-page
- :active (/= (Wand:images-num image-wand) 1)]))
+ :active (Wand:has-next-image image-wand)]
+ ["Previous Page" Wand-mode-prev-page
+ :active (Wand:has-prev-image image-wand)]
+ ["First Page" Wand-mode-first-page
+ :active (/= (Wand:iterator-index image-wand) 0) ]
+ ["Last Page" Wand-mode-last-page
+ :active (/= (Wand:iterator-index image-wand)
+ (1- (Wand:images-num image-wand))) ]
+ "-"
+ ["Goto Page" Wand-mode-goto-page
+ :active (/= (Wand:images-num image-wand) 1)]))
(defun Wand-menu-region-operations (not-used)
"Generate menu for region operations."
(mapcar #'(lambda (ro)
- (vector (get ro 'menu-name) ro :active 'preview-region))
- (apropos-internal "^Wand-mode-"
- #'(lambda (c)
- (and (commandp c)
- (get c 'region-operation)
- (get c 'menu-name))))))
+ (vector (get ro 'menu-name) ro :active 'preview-region))
+ (apropos-internal "^Wand-mode-"
+ #'(lambda (c)
+ (and (commandp c)
+ (get c 'region-operation)
+ (get c 'menu-name))))))
(defun Wand-mode-commands-by-tag (tag)
"Return list of wand command for which TAG property is set."
(apropos-internal "^Wand-mode-"
- #'(lambda (c) (and (commandp c) (get c tag)))))
+ #'(lambda (c) (and (commandp c) (get c tag)))))
(defun Wand-menu-generate (tag)
"Generate menu structure for TAG commands."
(mapcar #'(lambda (to)
- (vector (get to 'menu-name) to))
- (remove-if-not #'(lambda (c) (get c tag))
- (Wand-mode-commands-by-tag 'menu-name))))
+ (vector (get to 'menu-name) to))
+ (remove-if-not #'(lambda (c) (get c tag))
+ (Wand-mode-commands-by-tag 'menu-name))))
(defun Wand-mode-popup-menu (be)
"Popup wand menu."
(defmacro Wand-possible-for-region (wand &rest body)
`(if preview-region
(let* ((iwand ,wand)
- (region (Wand-mode-image-region))
- (wand (apply #'Wand:image-region iwand region)))
- (unwind-protect
- (progn
- ,@body
- (Wand:image-composite iwand wand :CopyCompositeOp
- (nth 2 region) (nth 3 region)))
- (setq preview-region nil)
- (Wand:delete-wand wand)))
+ (region (Wand-mode-image-region))
+ (wand (apply #'Wand:image-region iwand region)))
+ (unwind-protect
+ (progn
+ ,@body
+ (Wand:image-composite iwand wand :CopyCompositeOp
+ (nth 2 region) (nth 3 region)))
+ (setq preview-region nil)
+ (Wand:delete-wand wand)))
,@body))
(put 'Wand-possible-for-region 'lisp-indent-function 'defun)
"Extract RGB pixels from WAND."
(let ((target (make-ffi-object 'c-data (* w h 3))))
(when (Wand:MagickGetImagePixels
- wand x y w h "RGB" :char-pixel target)
+ wand x y w h "RGB" :char-pixel target)
(Wand:pixels-extract-colors (ffi-get target) 3))))
(defun Wand:get-rgb-pixel-at (wand x y)
"Simple red PIXELS fixator.
Normalize pixel color if it is too 'red'."
(let* ((rchan '(0.1 0.6 0.3))
- (gchan '(0.0 1.0 0.0))
- (bchan '(0.0 0.0 1.0))
- (rnorm (/ 1.0 (apply #'+ rchan)))
- (gnorm (/ 1.0 (apply #'+ gchan)))
- (bnorm (/ 1.0 (apply #'+ bchan))))
+ (gchan '(0.0 1.0 0.0))
+ (bchan '(0.0 0.0 1.0))
+ (rnorm (/ 1.0 (apply #'+ rchan)))
+ (gnorm (/ 1.0 (apply #'+ gchan)))
+ (bnorm (/ 1.0 (apply #'+ bchan))))
(flet ((normalize (chan norm r g b)
- (min 255 (int (* norm (+ (* (first chan) r)
- (* (second chan) g)
- (* (third chan) b)))))))
+ (min 255 (int (* norm (+ (* (first chan) r)
+ (* (second chan) g)
+ (* (third chan) b)))))))
(mapcar #'(lambda (pixel-value)
- (multiple-value-bind (r g b) pixel-value
- (if (>= r (* Wand-mode-redeye-threshold g))
- (list (normalize rchan rnorm r g b)
- (normalize gchan gnorm r g b)
- (normalize bchan bnorm r g b))
- (list r g b))))
- pixels))))
+ (multiple-value-bind (r g b) pixel-value
+ (if (>= r (* Wand-mode-redeye-threshold g))
+ (list (normalize rchan rnorm r g b)
+ (normalize gchan gnorm r g b)
+ (normalize bchan bnorm r g b))
+ (list r g b))))
+ pixels))))
(defun Wand-mode-redeye-blur-radius (w h)
"Return apropriate blur radius for region of width W and height H.
(Wand:MagickConstituteImage
cw w h "RGB" :char-pixel
(let ((stor (make-ffi-object 'c-data (* w h 3))))
- (ffi-set stor (Wand:pixels-arrange-colors
- (Wand-fix-red-pixels
- (Wand:get-image-rgb-pixels wand x y w h))))
- stor))
+ (ffi-set stor (Wand:pixels-arrange-colors
+ (Wand-fix-red-pixels
+ (Wand:get-image-rgb-pixels wand x y w h))))
+ stor))
;; Limit blur effect to ellipse at the center of REGION by
;; setting clip mask
(let ((mask (Wand:copy-wand cw)))
- (unwind-protect
- (progn
- (Wand-with-drawing-wand dw
- (Wand-with-pixel-wand pw
- (setf (Wand:pixel-color pw) "white")
- (setf (Wand:draw-fill-color dw) pw)
- (Wand:draw-color dw 0.0 0.0 :ResetMethod))
- (Wand-with-pixel-wand pw
- (setf (Wand:pixel-color pw) "black")
- (setf (Wand:draw-fill-color dw) pw))
- (Wand:draw-ellipse
- dw (/ w 2.0) (/ h 2.0) (/ w 2.0) (/ h 2.0) 0.0 360.0)
- (Wand:MagickDrawImage mask dw))
- (setf (Wand:clip-mask cw) mask))
- (Wand:delete-wand mask)))
+ (unwind-protect
+ (progn
+ (Wand-with-drawing-wand dw
+ (Wand-with-pixel-wand pw
+ (setf (Wand:pixel-color pw) "white")
+ (setf (Wand:draw-fill-color dw) pw)
+ (Wand:draw-color dw 0.0 0.0 :ResetMethod))
+ (Wand-with-pixel-wand pw
+ (setf (Wand:pixel-color pw) "black")
+ (setf (Wand:draw-fill-color dw) pw))
+ (Wand:draw-ellipse
+ dw (/ w 2.0) (/ h 2.0) (/ w 2.0) (/ h 2.0) 0.0 360.0)
+ (Wand:MagickDrawImage mask dw))
+ (setf (Wand:clip-mask cw) mask))
+ (Wand:delete-wand mask)))
(Wand:gaussian-blur-image
cw 0.0 (Wand-mode-redeye-blur-radius w h))
(define-Wand-operation zoom (wand outp factor)
(let ((nw (funcall (if outp #'/ #'*)
- (Wand:image-width wand) (float factor)))
- (nh (funcall (if outp #'/ #'*)
- (Wand:image-height wand) (float factor))))
+ (Wand:image-width wand) (float factor)))
+ (nh (funcall (if outp #'/ #'*)
+ (Wand:image-height wand) (float factor))))
(Wand:scale-image wand (round nw) (round nh))))
(define-Wand-operation sample (wand width height)
(defvar Wand-patterns
(mapcar (lambda (x) (list (symbol-name x)))
- '(bricks checkerboard circles crosshatch crosshatch30 crosshatch45
- fishscales gray0 gray5 gray10 gray15 gray20 gray25 gray30
- gray35 gray40 gray45 gray50 gray55 gray60 gray65 gray70
- gray75 gray80 gray85 gray90 gray95 gray100 hexagons horizontal
- horizontalsaw hs_bdiagonal hs_cross
- hs_diagcross hs_fdiagonal hs_horizontal hs_vertical left30
- left45 leftshingle octagons right30 right45 rightshingle
- smallfishscales vertical verticalbricks
- verticalleftshingle verticalrightshingle verticalsaw)))
+ '(bricks checkerboard circles crosshatch crosshatch30 crosshatch45
+ fishscales gray0 gray5 gray10 gray15 gray20 gray25 gray30
+ gray35 gray40 gray45 gray50 gray55 gray60 gray65 gray70
+ gray75 gray80 gray85 gray90 gray95 gray100 hexagons horizontal
+ horizontalsaw hs_bdiagonal hs_cross
+ hs_diagcross hs_fdiagonal hs_horizontal hs_vertical left30
+ left45 leftshingle octagons right30 right45 rightshingle
+ smallfishscales vertical verticalbricks
+ verticalleftshingle verticalrightshingle verticalsaw)))
(define-Wand-operation pattern (wand pattern op)
(Wand-with-wand cb-wand
(setf (Wand:image-size cb-wand)
- (cons (Wand:image-width wand) (Wand:image-height wand)))
+ (cons (Wand:image-width wand) (Wand:image-height wand)))
(Wand:MagickReadImage cb-wand (concat "pattern:" pattern))
(Wand:image-composite wand cb-wand
- (cdr (assoc op WandCompositeOperator-completion-table)) 0 0)))
+ (cdr (assoc op WandCompositeOperator-completion-table)) 0 0)))
;;}}}
;;{{{ Operations list functions
(defun Wand-operation-apply (operation wand &rest args)
"Apply OPERATION to WAND using addition arguments ARGS."
(setq operations-list
- (append operations-list (list (cons operation args))))
+ (append operations-list (list (cons operation args))))
(setq undo-list nil) ; Reset undo
(apply (Wand-operation-lookup operation) wand args))
"Apply all operations in OPERATIONS list."
(dolist (op (or operations operations-list))
(apply (Wand-operation-lookup (car op))
- wand (cdr op))))
+ wand (cdr op))))
;;}}}
;;{{{ Helper functions
(defun Wand-mode-image-region ()
"Return region in real image, according to `preview-region'."
(let ((off-x (get preview-wand 'offset-x))
- (off-y (get preview-wand 'offset-y))
- (xcoeff (// (Wand:image-width image-wand)
- (Wand:image-width preview-wand)))
- (ycoeff (// (Wand:image-height image-wand)
- (Wand:image-height preview-wand))))
+ (off-y (get preview-wand 'offset-y))
+ (xcoeff (// (Wand:image-width image-wand)
+ (Wand:image-width preview-wand)))
+ (ycoeff (// (Wand:image-height image-wand)
+ (Wand:image-height preview-wand))))
(mapcar #'round (list (* (nth 0 preview-region) xcoeff)
- (* (nth 1 preview-region) ycoeff)
- (* (+ (nth 2 preview-region) off-x) xcoeff)
- (* (+ (nth 3 preview-region) off-y) ycoeff)))))
+ (* (nth 1 preview-region) ycoeff)
+ (* (+ (nth 2 preview-region) off-x) xcoeff)
+ (* (+ (nth 3 preview-region) off-y) ycoeff)))))
(defun Wand-mode-file-info ()
"Return info about file as a string."
(declare (special off-x))
(declare (special off-y))
(let ((iw (Wand:image-width image-wand))
- (ih (Wand:image-height image-wand))
- (ow (Wand:image-orig-width image-wand))
- (oh (Wand:image-orig-height image-wand)))
+ (ih (Wand:image-height image-wand))
+ (ow (Wand:image-orig-width image-wand))
+ (oh (Wand:image-orig-height image-wand)))
(concat "File: " (file-name-nondirectory buffer-file-name)
- " (" (Wand:get-magick-property image-wand "size") "), "
- (Wand:image-format image-wand)
- " " (format "%dx%d" iw ih)
- (if (and (not (zerop ow)) (not (zerop oh))
- (or (/= ow iw) (/= oh ih)))
- (format " (Orig: %dx%d)" ow oh)
- "")
- (if (> (Wand:images-num image-wand) 1)
- (format ", Page: %d/%d" (1+ (Wand:iterator-index image-wand))
- (Wand:images-num image-wand))
- "")
- ;; Print offset info
- (if (and preview-wand (boundp 'off-x) (boundp 'off-y)
- (or (positivep off-x) (positivep off-y)))
- (format ", Offset: +%d+%d" off-x off-y)
- "")
- ;; Print region info
- (if preview-region
- (apply #'format ", Region: %dx%d+%d+%d"
- (Wand-mode-image-region))
- ""))))
+ " (" (Wand:get-magick-property image-wand "size") "), "
+ (Wand:image-format image-wand)
+ " " (format "%dx%d" iw ih)
+ (if (and (not (zerop ow)) (not (zerop oh))
+ (or (/= ow iw) (/= oh ih)))
+ (format " (Orig: %dx%d)" ow oh)
+ "")
+ (if (> (Wand:images-num image-wand) 1)
+ (format ", Page: %d/%d" (1+ (Wand:iterator-index image-wand))
+ (Wand:images-num image-wand))
+ "")
+ ;; Print offset info
+ (if (and preview-wand (boundp 'off-x) (boundp 'off-y)
+ (or (positivep off-x) (positivep off-y)))
+ (format ", Offset: +%d+%d" off-x off-y)
+ "")
+ ;; Print region info
+ (if preview-region
+ (apply #'format ", Region: %dx%d+%d+%d"
+ (Wand-mode-image-region))
+ ""))))
(defun Wand-mode-iptc-split-keywords (tag-value)
(mapcar #'(lambda (kw) (cons 'keyword kw))
- (nreverse
- (split-string tag-value "\\(, \\|,\\)"))))
+ (nreverse
+ (split-string tag-value "\\(, \\|,\\)"))))
(defun Wand-mode-iptc-from-widgets (widgets)
"Return profile made up from WIDGETS info."
(mapcan
#'(lambda (widget)
(let ((iptc-tag (widget-get widget :iptc-tag))
- (tag-value (widget-get widget :value)))
- (cond ((string= tag-value "") nil)
- ((eq iptc-tag 'keywords)
- ;; Special case for keywords
- (Wand-mode-iptc-split-keywords tag-value))
- (t (list (cons iptc-tag tag-value))))))
+ (tag-value (widget-get widget :value)))
+ (cond ((string= tag-value "") nil)
+ ((eq iptc-tag 'keywords)
+ ;; Special case for keywords
+ (Wand-mode-iptc-split-keywords tag-value))
+ (t (list (cons iptc-tag tag-value))))))
widgets))
(defun Wand-mode-iptc-notify (wid &rest args)
(kill-local-variable 'widget-field-list)
(let* ((iptc (Wand:image-profile-iptc image-wand))
- (cpt (cdr (assq 'caption iptc)))
- (kws (mapcar #'cdr (remove-if-not
- #'(lambda (e) (eq 'keyword (car e)))
- iptc))))
+ (cpt (cdr (assq 'caption iptc)))
+ (kws (mapcar #'cdr (remove-if-not
+ #'(lambda (e) (eq 'keyword (car e)))
+ iptc))))
(when cpt
(widget-create 'editable-field
- :tag "Caption"
- :format "IPTC Caption: %v"
- :iptc-tag 'caption
- :notify #'Wand-mode-iptc-notify
- cpt))
+ :tag "Caption"
+ :format "IPTC Caption: %v"
+ :iptc-tag 'caption
+ :notify #'Wand-mode-iptc-notify
+ cpt))
(when kws
(widget-create 'editable-field
- :format "IPTC Keywords: %v"
- :tag "Keywords"
- :iptc-tag 'keywords
- :notify #'Wand-mode-iptc-notify
- (mapconcat #'identity kws ", ")))
+ :format "IPTC Keywords: %v"
+ :tag "Keywords"
+ :iptc-tag 'keywords
+ :notify #'Wand-mode-iptc-notify
+ (mapconcat #'identity kws ", ")))
(widget-setup)))
(defun Wand-mode-add-iptc-tag (tag value)
"Add TAG to ITPC profile."
(interactive (list (completing-read
- "IPTC Tag: " '(("caption") ("keywords")) nil t)
- (read-string "ITPC Tag value: ")))
+ "IPTC Tag: " '(("caption") ("keywords")) nil t)
+ (read-string "ITPC Tag value: ")))
(let ((tags-val (cond ((string= tag "caption")
- (list (cons 'caption value)))
- ((string= tag "keywords")
- (Wand-mode-iptc-split-keywords value))
- (t (error "Invalid IPTC tag")))))
+ (list (cons 'caption value)))
+ ((string= tag "keywords")
+ (Wand-mode-iptc-split-keywords value))
+ (t (error "Invalid IPTC tag")))))
(Wand:image-save-iptc-profile
image-wand (nconc (Wand-mode-iptc-from-widgets widget-field-list)
- tags-val))
+ tags-val))
(Wand-mode-update-info)))
(defun Wand-mode-insert-info ()
;; XXX iptc may set those below again
(let ((inhibit-read-only t)
- (before-change-functions nil)
- (after-change-functions nil))
+ (before-change-functions nil)
+ (after-change-functions nil))
(when (and Wand-mode-show-operations)
(when operations-list
- (insert (format "Operations: %S" operations-list) "\n"))
+ (insert (format "Operations: %S" operations-list) "\n"))
(when Wand-global-operations-list
- (insert (format "Global operations: %S"
- Wand-global-operations-list) "\n")))
+ (insert (format "Global operations: %S"
+ Wand-global-operations-list) "\n")))
;; Info about pickup color
(when (boundp 'pickup-color)
(declare (special pickup-color))
(let* ((cf (make-face (gensym "dcolor-") nil t))
- (place (car pickup-color))
- (color (cdr pickup-color))
- (fcol (apply #'format "#%02x%02x%02x" color)))
- (set-face-background cf fcol)
- (insert (format "Color: +%d+%d " (car place) (cdr place)))
- (insert-face " " cf)
- (insert (format " %s R:%d, G:%d, B:%d\n" fcol
- (car color) (cadr color) (caddr color)))))
+ (place (car pickup-color))
+ (color (cdr pickup-color))
+ (fcol (apply #'format "#%02x%02x%02x" color)))
+ (set-face-background cf fcol)
+ (insert (format "Color: +%d+%d " (car place) (cdr place)))
+ (insert-face " " cf)
+ (insert (format " %s R:%d, G:%d, B:%d\n" fcol
+ (car color) (cadr color) (caddr color)))))
(run-hooks 'Wand-insert-info-hook)))
(defun Wand-mode-update-info ()
"Only update info region."
(let ((inhibit-read-only t)
- before-change-functions
- after-change-functions)
+ before-change-functions
+ after-change-functions)
(mapc 'widget-delete widget-field-list)
(save-excursion
(goto-char (point-min))
(delete-region (point-at-bol)
- (save-excursion
- (goto-char (point-max))
- (point-at-bol)))
+ (save-excursion
+ (goto-char (point-max))
+ (point-at-bol)))
(Wand-mode-insert-info))
(set-buffer-modified-p nil)))
"Update file info."
(when Wand-mode-show-fileinfo
(let ((inhibit-read-only t)
- before-change-functions
- after-change-functions)
+ before-change-functions
+ after-change-functions)
(save-excursion
- (goto-char (point-min))
- (delete-region (point-at-bol) (point-at-eol))
- (insert (Wand-mode-file-info))))
+ (goto-char (point-min))
+ (delete-region (point-at-bol) (point-at-eol))
+ (insert (Wand-mode-file-info))))
(set-buffer-modified-p nil)))
(defun Wand-mode-preview-with-region ()
(incf x (get preview-wand 'offset-x))
(incf y (get preview-wand 'offset-y))
(Wand-with-drawing-wand dw
- (Wand-with-pixel-wand pw
- (setf (Wand:pixel-color pw) Wand-mode-region-outline-color)
- (Wand:DrawSetStrokeColor dw pw))
- (Wand-with-pixel-wand pw
- (setf (Wand:pixel-color pw) Wand-mode-region-fill-color)
- (setf (Wand:draw-fill-color dw) pw))
- (setf (Wand:draw-stroke-width dw) Wand-mode-region-outline-width
- (Wand:draw-stroke-opacity dw) Wand-mode-region-outline-opacity
- (Wand:draw-fill-opacity dw) Wand-mode-region-fill-opacity)
- (Wand:draw-lines dw (list (cons x y) (cons (+ x w) y)
- (cons (+ x w) (+ y h)) (cons x (+ y h))
- (cons x y)))
- (let ((nw (Wand:copy-wand preview-wand)))
- (put nw 'offset-x (get preview-wand 'offset-x))
- (put nw 'offset-y (get preview-wand 'offset-y))
- (Wand:MagickDrawImage nw dw)
- nw)))))
+ (Wand-with-pixel-wand pw
+ (setf (Wand:pixel-color pw) Wand-mode-region-outline-color)
+ (Wand:DrawSetStrokeColor dw pw))
+ (Wand-with-pixel-wand pw
+ (setf (Wand:pixel-color pw) Wand-mode-region-fill-color)
+ (setf (Wand:draw-fill-color dw) pw))
+ (setf (Wand:draw-stroke-width dw) Wand-mode-region-outline-width
+ (Wand:draw-stroke-opacity dw) Wand-mode-region-outline-opacity
+ (Wand:draw-fill-opacity dw) Wand-mode-region-fill-opacity)
+ (Wand:draw-lines dw (list (cons x y) (cons (+ x w) y)
+ (cons (+ x w) (+ y h)) (cons x (+ y h))
+ (cons x y)))
+ (let ((nw (Wand:copy-wand preview-wand)))
+ (put nw 'offset-x (get preview-wand 'offset-x))
+ (put nw 'offset-y (get preview-wand 'offset-y))
+ (Wand:MagickDrawImage nw dw)
+ nw)))))
(defun Wand-mode-insert-preview ()
"Display wand W at the point."
;; NOTE: if size not changed, then keep offset-x and offset-y
;; properties
(let ((saved-w (and preview-wand (Wand:image-width preview-wand)))
- (saved-h (and preview-wand (Wand:image-height preview-wand)))
- (off-x (or (get preview-wand 'offset-x) 0))
- (off-y (or (get preview-wand 'offset-y) 0)))
+ (saved-h (and preview-wand (Wand:image-height preview-wand)))
+ (off-x (or (get preview-wand 'offset-x) 0))
+ (off-y (or (get preview-wand 'offset-y) 0)))
;; Delete old preview and create new one
(when preview-wand (Wand:delete-wand preview-wand))
(setq preview-wand (Wand:get-image image-wand))
;; displayed-text-pixel-height, and then restore
;; Rescale preview to fit the window
(let ((scale-h (- (window-text-area-pixel-height)
- (if (zerop (buffer-size)) 0
- (unwind-protect
- (progn
- (backward-delete-char)
- (window-displayed-text-pixel-height))
- (insert "\n")))))
- (scale-w (window-text-area-pixel-width)))
+ (if (zerop (buffer-size)) 0
+ (unwind-protect
+ (progn
+ (backward-delete-char)
+ (window-displayed-text-pixel-height))
+ (insert "\n")))))
+ (scale-w (window-text-area-pixel-width)))
(when (and (get image-wand 'fitting)
- (Wand:fit-size preview-wand scale-w scale-h))
- (message "Rescale to %dx%d"
- (Wand:image-width preview-wand)
- (Wand:image-height preview-wand))))
+ (Wand:fit-size preview-wand scale-w scale-h))
+ (message "Rescale to %dx%d"
+ (Wand:image-width preview-wand)
+ (Wand:image-height preview-wand))))
;; Set offset properties
(if (and (eq saved-w (Wand:image-width preview-wand))
- (eq saved-h (Wand:image-height preview-wand)))
- (progn (put preview-wand 'offset-x off-x)
- (put preview-wand 'offset-y off-y))
+ (eq saved-h (Wand:image-height preview-wand)))
+ (progn (put preview-wand 'offset-x off-x)
+ (put preview-wand 'offset-y off-y))
(put preview-wand 'offset-x 0)
(put preview-wand 'offset-y 0))
(let ((pwr (Wand-mode-preview-with-region)))
(unwind-protect
- (progn
- (set-extent-end-glyph
- preview-extent (Wand-mode-preview-glyph (or pwr preview-wand)))
- (set-extent-endpoints
- preview-extent (point) (point) (current-buffer)))
- (when pwr (Wand:delete-wand pwr))))))
+ (progn
+ (set-extent-end-glyph
+ preview-extent (Wand-mode-preview-glyph (or pwr preview-wand)))
+ (set-extent-endpoints
+ preview-extent (point) (point) (current-buffer)))
+ (when pwr (Wand:delete-wand pwr))))))
(defun Wand-redisplay (&optional wand)
"Redisplay Wand buffer with possible a new WAND."
;;;###autoload
(defun Wand-display-noselect (file)
(let* ((bn (format "*Wand: %s*" (file-name-nondirectory file)))
- (buf (if (and (eq major-mode 'Wand-mode)
- (not (get-buffer bn)))
- ;; Use current buffer
- (progn
- (rename-buffer bn)
- (current-buffer))
- (get-buffer-create bn))))
+ (buf (if (and (eq major-mode 'Wand-mode)
+ (not (get-buffer bn)))
+ ;; Use current buffer
+ (progn
+ (rename-buffer bn)
+ (current-buffer))
+ (get-buffer-create bn))))
(with-current-buffer buf
(unless (eq major-mode 'Wand-mode)
- ;; Initialise local variables
- (kill-all-local-variables)
- (make-variable-buffer-local 'image-wand)
- (make-variable-buffer-local 'preview-wand)
- (make-variable-buffer-local 'preview-region)
- (make-variable-buffer-local 'preview-extent)
- (make-variable-buffer-local 'operations-list)
- (make-variable-buffer-local 'undo-list)
- (make-variable-buffer-local 'kill-buffer-hook)
- (setq operations-list nil)
- (setq undo-list nil)
- (setq preview-wand nil)
- (setq preview-extent (make-extent 0 0 ""))
- (setq image-wand (Wand:make-wand))
- (put image-wand 'fitting Wand-mode-auto-fit)
-
- (use-local-map Wand-mode-map)
- (setq mode-name "Wand")
- (setq major-mode 'Wand-mode)
- (setq buffer-read-only t)
- ;; Setup menubar
- (when (featurep 'menubar)
- (set-buffer-menubar current-menubar)
- (add-submenu '() Wand-menu)
- (setq mode-popup-menu Wand-menu))
- (add-hook 'kill-buffer-hook 'Wand-mode-cleanup))
+ ;; Initialise local variables
+ (kill-all-local-variables)
+ (make-variable-buffer-local 'image-wand)
+ (make-variable-buffer-local 'preview-wand)
+ (make-variable-buffer-local 'preview-region)
+ (make-variable-buffer-local 'preview-extent)
+ (make-variable-buffer-local 'operations-list)
+ (make-variable-buffer-local 'undo-list)
+ (make-variable-buffer-local 'kill-buffer-hook)
+ (setq operations-list nil)
+ (setq undo-list nil)
+ (setq preview-wand nil)
+ (setq preview-extent (make-extent 0 0 ""))
+ (setq image-wand (Wand:make-wand))
+ (put image-wand 'fitting Wand-mode-auto-fit)
+
+ (use-local-map Wand-mode-map)
+ (setq mode-name "Wand")
+ (setq major-mode 'Wand-mode)
+ (setq buffer-read-only t)
+ ;; Setup menubar
+ (when (featurep 'menubar)
+ (set-buffer-menubar current-menubar)
+ (add-submenu '() Wand-menu)
+ (setq mode-popup-menu Wand-menu))
+ (add-hook 'kill-buffer-hook 'Wand-mode-cleanup))
(when preview-wand
- (Wand:delete-wand preview-wand))
+ (Wand:delete-wand preview-wand))
(setq preview-wand nil)
(setq preview-region nil)
(setq operations-list nil)
(Wand:clear-wand image-wand)
;; Fix buffer-file-name in case of viewing directory
(when (file-directory-p file)
- (setq file (or (Wand-next-file (concat file "/.")) file)))
+ (setq file (or (Wand-next-file (concat file "/.")) file)))
(setq buffer-file-name file)
(setq default-directory (file-name-directory file))
(unless (Wand:read-image image-wand file)
- (kill-buffer (current-buffer))
- (error "Can't read file %s" file))
+ (kill-buffer (current-buffer))
+ (error "Can't read file %s" file))
(when Wand-mode-auto-rotate
- (Wand:correct-orientation image-wand))
+ (Wand:correct-orientation image-wand))
;; Apply operations in case global operations list is used
(mapc #'(lambda (op)
- (apply #'Wand-operation-apply
- (car op) image-wand (cdr op)))
- Wand-global-operations-list)
+ (apply #'Wand-operation-apply
+ (car op) image-wand (cdr op)))
+ Wand-global-operations-list)
(Wand-redisplay)
(defun Wand-find-file-enable ()
"Enable `find-file' to use `Wand-display' for supported filetypes."
(push '(Wand-file-supported-for-read-p . Wand-display-noselect)
- find-file-magic-files-alist))
+ find-file-magic-files-alist))
(defun Wand-mode-cleanup ()
"Cleanup when wand buffer is killed."
(let ((iw image-wand))
(with-displaying-help-buffer
#'(lambda ()
- (set-buffer standard-output)
- (insert (Wand:identify-image iw)))
+ (set-buffer standard-output)
+ (insert (Wand:identify-image iw)))
"Wand:info")))
(defun Wand-mode-operations-table ()
"Return completion table for Wand operations."
(mapcar #'(lambda (to)
- (cons (downcase (get to 'menu-name)) to))
- (Wand-mode-commands-by-tag 'menu-name)))
+ (cons (downcase (get to 'menu-name)) to))
+ (Wand-mode-commands-by-tag 'menu-name)))
(defun Wand-mode-operate (op-name)
"Operate on image."
(interactive (list (completing-read
- "Operation: " (Wand-mode-operations-table)
- nil t)))
+ "Operation: " (Wand-mode-operations-table)
+ nil t)))
(let ((op (assoc op-name (Wand-mode-operations-table))))
(let ((current-prefix-arg current-prefix-arg))
(call-interactively (cdr op)))))
"Return non-nil if Wand can read files in FORMAT."
(unless (member (downcase format) Wand-formats-read-unsupported)
(let ((fi (Wand:GetMagickInfo
- format (ffi-address-of
- (make-ffi-object 'MagickExceptionInfo)))))
+ format (ffi-address-of
+ (make-ffi-object 'MagickExceptionInfo)))))
(and (not (ffi-null-p fi))
- (not (ffi-null-p (MagickInfo->decoder fi)))
- ))))
+ (not (ffi-null-p (MagickInfo->decoder fi)))
+ ))))
;; ImageMagick on linux treats any format to be RAW for some reason
- ;; We can't read raw formats
+ ;; We can't read raw formats
; (not (MagickInfo->raw fi))))))
(defcustom Wand-formats-write-unsupported
"Return non-nil if Wand can write files in FORMAT."
(unless (member (downcase format) Wand-formats-write-unsupported)
(let ((fi (Wand:GetMagickInfo
- format (ffi-address-of
- (make-ffi-object 'MagickExceptionInfo)))))
+ format (ffi-address-of
+ (make-ffi-object 'MagickExceptionInfo)))))
(and (not (ffi-null-p fi))
- (not (ffi-null-p (MagickInfo->encoder fi)))))))
+ (not (ffi-null-p (MagickInfo->encoder fi)))))))
;;;###autoload
(defun Wand-file-supported-for-read-p (file)
(let ((ext (file-name-extension file)))
(or (and ext (Wand-format-supported-for-read-p ext))
- (multiple-value-bind (itype imagetext)
- (split-string (or (magic:file-type file) " ") " ")
- (and imagetext
- (string= (downcase imagetext) "image")
- (Wand-format-supported-for-read-p itype))))))
+ (multiple-value-bind (itype imagetext)
+ (split-string (or (magic:file-type file) " ") " ")
+ (and imagetext
+ (string= (downcase imagetext) "image")
+ (Wand-format-supported-for-read-p itype))))))
(defun Wand-formats-list (fmt-regexp &optional mode)
"Return names of supported formats that matches FMT-REGEXP.
'read-write - Formats that we can and read and write
'any or nil - Any format (default)."
(let* ((excp (make-ffi-object 'MagickExceptionInfo))
- (num (make-ffi-object 'unsigned-long))
- (fil (Wand:GetMagickInfoList
- fmt-regexp (ffi-address-of num) (ffi-address-of excp))))
+ (num (make-ffi-object 'unsigned-long))
+ (fil (Wand:GetMagickInfoList
+ fmt-regexp (ffi-address-of num) (ffi-address-of excp))))
(unless (ffi-null-p fil)
(unwind-protect
- (loop for n from 0 below (ffi-get num)
- with minfo = nil
- do (setq minfo (ffi-aref fil n))
- if (ecase (or mode 'any)
- (read (not (ffi-null-p (MagickInfo->decoder minfo))))
- (write (not (ffi-null-p (MagickInfo->encoder minfo))))
- (read-write
- (and (not (ffi-null-p (MagickInfo->decoder minfo)))
- (not (ffi-null-p (MagickInfo->encoder minfo)))))
- (any t))
- collect (ffi-get (MagickInfo->name minfo) :type 'c-string))
- (Wand:RelinquishMemory fil)))))
+ (loop for n from 0 below (ffi-get num)
+ with minfo = nil
+ do (setq minfo (ffi-aref fil n))
+ if (ecase (or mode 'any)
+ (read (not (ffi-null-p (MagickInfo->decoder minfo))))
+ (write (not (ffi-null-p (MagickInfo->encoder minfo))))
+ (read-write
+ (and (not (ffi-null-p (MagickInfo->decoder minfo)))
+ (not (ffi-null-p (MagickInfo->encoder minfo)))))
+ (any t))
+ collect (ffi-get (MagickInfo->name minfo) :type 'c-string))
+ (Wand:RelinquishMemory fil)))))
;;}}}
;;{{{ File navigation commands
"Return next (to CURFILE) image file in the directory.
If REVERSE-ORDER is specified, then return previous file."
(let* ((dir (file-name-directory curfile))
- (fn (file-name-nondirectory curfile))
- (dfiles (directory-files dir nil nil 'sorted-list t))
- (nfiles (cdr (member fn (if reverse-order (nreverse dfiles) dfiles)))))
+ (fn (file-name-nondirectory curfile))
+ (dfiles (directory-files dir nil nil 'sorted-list t))
+ (nfiles (cdr (member fn (if reverse-order (nreverse dfiles) dfiles)))))
(while (and nfiles (not (Wand-file-supported-for-read-p
- (concat dir (car nfiles)))))
+ (concat dir (car nfiles)))))
(setq nfiles (cdr nfiles)))
(and nfiles (concat dir (car nfiles)))))
"View last image in the directory."
(interactive)
(let ((rf buffer-file-name)
- (ff (Wand-next-file buffer-file-name reverse)))
+ (ff (Wand-next-file buffer-file-name reverse)))
(while ff
(setq rf ff)
(setq ff (Wand-next-file rf reverse)))
"Display last image in image chain."
(interactive
(list (if (numberp current-prefix-arg)
- current-prefix-arg
- (read-number "Goto page: " t))))
+ current-prefix-arg
+ (read-number "Goto page: " t))))
;; Internally images in chain counts from 0
(unless (setf (Wand:iterator-index image-wand) (1- n))
(error "No such page" n))
"Rotate image to the left.
If ARG is specified then rotate on ARG degree."
(interactive (list (or (and current-prefix-arg
- (prefix-numeric-value current-prefix-arg))
- 90)))
+ (prefix-numeric-value current-prefix-arg))
+ 90)))
(Wand-mode-rotate (- arg)))
(defun Wand-mode-rotate-right (arg)
"Rotate image to the right.
If ARG is specified then rotate on ARG degree."
(interactive (list (or (and current-prefix-arg
- (prefix-numeric-value current-prefix-arg))
- 90)))
+ (prefix-numeric-value current-prefix-arg))
+ 90)))
(Wand-mode-rotate arg))
(defun Wand-mode-raise (arg)
(defun Wand-mode-sharpen (radius sigma)
"Sharpen image with by RADIUS and SIGMA."
(interactive (list (read-number "Radius [1]: " nil "1")
- (read-number (format "Sigma [%d]: " Wand-mode-sigma)
- nil (number-to-string Wand-mode-sigma))))
+ (read-number (format "Sigma [%d]: " Wand-mode-sigma)
+ nil (number-to-string Wand-mode-sigma))))
(Wand-operation-apply 'sharpen image-wand radius sigma)
(Wand-redisplay))
(put 'Wand-mode-sharpen 'can-preview :SharpenPreview)
(defun Wand-mode-gaussian-blur (radius sigma)
"Apply gaussian blur of RADIUS and SIGMA to the image."
(interactive (list (read-number "Radius [1]: " nil "1")
- (read-number (format "Sigma [%d]: " Wand-mode-sigma)
- nil (number-to-string Wand-mode-sigma))))
+ (read-number (format "Sigma [%d]: " Wand-mode-sigma)
+ nil (number-to-string Wand-mode-sigma))))
(Wand-operation-apply 'gauss-blur image-wand radius sigma)
(Wand-redisplay))
(put 'Wand-mode-gaussian-blur 'can-preview :BlurPreview)
(defun Wand-mode-emboss (radius sigma)
"Emboss the image with RADIUS and SIGMA."
(interactive (list (read-number "Radius [1.0]: " nil "1.0")
- (read-number (format "Sigma [%d]: " Wand-mode-sigma)
- nil (number-to-string Wand-mode-sigma))))
+ (read-number (format "Sigma [%d]: " Wand-mode-sigma)
+ nil (number-to-string Wand-mode-sigma))))
(Wand-operation-apply 'emboss image-wand radius sigma)
(Wand-redisplay))
(put 'Wand-mode-emboss 'effect-operation t)
"Add noise of NOISE-TYPE."
(interactive
(list (completing-read "Noise type [poisson]: "
- (mapcar #'(lambda (ev)
- (let ((sn (symbol-name (car ev))))
- (list (and (string-match
- ":\\(.+\\)Noise" sn)
- (downcase
- (match-string 1 sn))))))
- (ffi-enum-values 'MagickNoiseType))
- nil t nil nil "poisson")))
+ (mapcar #'(lambda (ev)
+ (let ((sn (symbol-name (car ev))))
+ (list (and (string-match
+ ":\\(.+\\)Noise" sn)
+ (downcase
+ (match-string 1 sn))))))
+ (ffi-enum-values 'MagickNoiseType))
+ nil t nil nil "poisson")))
(let ((nt (intern (format ":%sNoise" (capitalize noise-type)))))
(Wand-operation-apply 'add-noise image-wand nt))
(Wand-redisplay))
"Increase or decrease contrast.
By default increase."
(interactive (list (completing-read
- "Contrast [increase]: " '(("increase") ("decrease"))
- nil t nil nil "increase")))
+ "Contrast [increase]: " '(("increase") ("decrease"))
+ nil t nil nil "increase")))
(Wand-operation-apply 'contrast image-wand (string= ctype "increase"))
(Wand-redisplay))
(put 'Wand-mode-contrast 'enhance-operation t)
(defun Wand-mode-modulate (type inc)
"Modulate image's brightness, saturation or hue."
(interactive (let* ((tp (completing-read
- "Modulate [saturation]: "
- '(("brightness") ("saturation") ("hue"))
- nil t nil nil "saturation"))
- (tinc (read-number (format "Increase %s [25%%]: " tp)
- nil "25")))
- (list (cond ((string= tp "brightness") :brightness)
- ((string= tp "hue") :hue)
- (t :saturation)) tinc)))
+ "Modulate [saturation]: "
+ '(("brightness") ("saturation") ("hue"))
+ nil t nil nil "saturation"))
+ (tinc (read-number (format "Increase %s [25%%]: " tp)
+ nil "25")))
+ (list (cond ((string= tp "brightness") :brightness)
+ ((string= tp "hue") :hue)
+ (t :saturation)) tinc)))
(Wand-operation-apply 'modulate image-wand type inc)
(Wand-redisplay))
(put 'Wand-mode-modulate 'enhance-operation t)
"Solarise image with solarize factor SF."
(interactive (list (read-number "Solarize factor [50%]: " nil "50")))
(Wand-operation-apply 'solarize image-wand
- (* (Wand:quantum-range) (/ sf 100.0)))
+ (* (Wand:quantum-range) (/ sf 100.0)))
(Wand-redisplay))
(put 'Wand-mode-solarize 'f/x-operation t)
(put 'Wand-mode-solarize 'menu-name "Solarize")
If prefix ARG is specified then radius for charcoal painting is ARG.
Default is 1."
(interactive (list (read-number "Radius [1.0]: " nil "1.0")
- (read-number "Sigma [1.0]: " nil "1.0")))
+ (read-number "Sigma [1.0]: " nil "1.0")))
(Wand-operation-apply 'charcoal image-wand radius sigma)
(Wand-redisplay))
(put 'Wand-mode-charcoal 'can-preview :CharcoalDrawingPreview)
"Apply sepia tone to image by THRESHOLD."
(interactive (list (read-number "Threshold [80%]: " nil "80")))
(Wand-operation-apply 'sepia-tone image-wand
- (* (Wand:quantum-range) (/ threshold 100.0)))
+ (* (Wand:quantum-range) (/ threshold 100.0)))
(Wand-redisplay))
(put 'Wand-mode-sepia-tone 'f/x-operation t)
(put 'Wand-mode-sepia-tone 'menu-name "Sepia Tone")
(defun Wand-mode-wave (amplitude wave-length)
"Create wave effect on image with AMPLITUDE and WAVE-LENGTH."
(interactive (list (read-number "Amplitude [2]: " nil "2")
- (read-number "Wave length [10]: " nil "10")))
+ (read-number "Wave length [10]: " nil "10")))
(Wand-operation-apply 'wave image-wand amplitude wave-length)
(Wand-redisplay))
(put 'Wand-mode-wave 'f/x-operation t)
(interactive "e")
(with-current-buffer (event-buffer event)
(let ((gc-cons-threshold most-positive-fixnum) ; inhibit gc
- (sx (event-glyph-x-pixel event))
- (sy (event-glyph-y-pixel event))
- (had-preview-region preview-region)
- (mouse-down t))
+ (sx (event-glyph-x-pixel event))
+ (sy (event-glyph-y-pixel event))
+ (had-preview-region preview-region)
+ (mouse-down t))
(setq preview-region (list 0 0 sx sy))
(while mouse-down
- (setq event (next-event event))
- (cond ((motion-event-p event)
- (let ((mx (event-glyph-x-pixel event))
- (my (event-glyph-y-pixel event)))
- (when (and mx my)
- (setq preview-region
- (list (abs (- sx mx)) (abs (- sy my))
- (min sx mx) (min sy my)))
- ;; Update info and preview image
- (Wand-mode-update-file-info)
- (let ((pwr (Wand-mode-preview-with-region)))
- (unwind-protect
- (set-extent-end-glyph
- preview-extent (Wand-mode-preview-glyph pwr))
- (Wand:delete-wand pwr))))))
-
- ((button-release-event-p event)
- (setq mouse-down nil)
- (if (and (positivep (nth 0 preview-region))
- (positivep (nth 1 preview-region)))
- ;; Save region
- (put image-wand 'last-preview-region preview-region)
-
- (setq preview-region nil)
- (if had-preview-region
- (progn
- ;; Remove any regions
- (Wand-mode-update-file-info)
- (set-extent-end-glyph
- preview-extent (Wand-mode-preview-glyph preview-wand)))
-
- ;; Otherwise pickup color
- (let* ((col (Wand:get-rgb-pixel-at preview-wand sx sy))
- (pickup-color (cons (cons sx sy) col)))
- (declare (special pickup-color))
- (Wand-mode-update-info)))))
- (t (dispatch-event event)))))))
+ (setq event (next-event event))
+ (cond ((motion-event-p event)
+ (let ((mx (event-glyph-x-pixel event))
+ (my (event-glyph-y-pixel event)))
+ (when (and mx my)
+ (setq preview-region
+ (list (abs (- sx mx)) (abs (- sy my))
+ (min sx mx) (min sy my)))
+ ;; Update info and preview image
+ (Wand-mode-update-file-info)
+ (let ((pwr (Wand-mode-preview-with-region)))
+ (unwind-protect
+ (set-extent-end-glyph
+ preview-extent (Wand-mode-preview-glyph pwr))
+ (Wand:delete-wand pwr))))))
+
+ ((button-release-event-p event)
+ (setq mouse-down nil)
+ (if (and (positivep (nth 0 preview-region))
+ (positivep (nth 1 preview-region)))
+ ;; Save region
+ (put image-wand 'last-preview-region preview-region)
+
+ (setq preview-region nil)
+ (if had-preview-region
+ (progn
+ ;; Remove any regions
+ (Wand-mode-update-file-info)
+ (set-extent-end-glyph
+ preview-extent (Wand-mode-preview-glyph preview-wand)))
+
+ ;; Otherwise pickup color
+ (let* ((col (Wand:get-rgb-pixel-at preview-wand sx sy))
+ (pickup-color (cons (cons sx sy) col)))
+ (declare (special pickup-color))
+ (Wand-mode-update-info)))))
+ (t (dispatch-event event)))))))
(defun Wand-mode-activate-region ()
"Activate last preview-region."
"Drag image to view unshown part of the image."
(interactive "e")
(let ((gc-cons-threshold most-positive-fixnum) ; inhibit gc
- (sx (event-glyph-x-pixel event))
- (sy (event-glyph-y-pixel event))
- (pw (Wand:image-width preview-wand))
- (ph (Wand:image-height preview-wand))
- (mouse-down t))
+ (sx (event-glyph-x-pixel event))
+ (sy (event-glyph-y-pixel event))
+ (pw (Wand:image-width preview-wand))
+ (ph (Wand:image-height preview-wand))
+ (mouse-down t))
(while mouse-down
(setq event (next-event event))
(if (or (motion-event-p event) (button-release-event-p event))
- (let ((off-x (+ (- sx (event-glyph-x-pixel event))
- (or (get preview-wand 'offset-x) 0)))
- (off-y (+ (- sy (event-glyph-y-pixel event))
- (or (get preview-wand 'offset-y) 0))))
- (when (< off-x 0) (setq off-x 0))
- (when (< off-y 0) (setq off-y 0))
- (Wand-mode-update-file-info)
- (if (motion-event-p event)
- (set-extent-end-glyph
- preview-extent (Wand:glyph-internal
- preview-wand off-x off-y
- (- pw off-x) (- ph off-y)))
-
- ;; Button released
- (setq mouse-down nil)
- (put preview-wand 'offset-x off-x)
- (put preview-wand 'offset-y off-y)))
-
- (dispatch-event event)))))
+ (let ((off-x (+ (- sx (event-glyph-x-pixel event))
+ (or (get preview-wand 'offset-x) 0)))
+ (off-y (+ (- sy (event-glyph-y-pixel event))
+ (or (get preview-wand 'offset-y) 0))))
+ (when (< off-x 0) (setq off-x 0))
+ (when (< off-y 0) (setq off-y 0))
+ (Wand-mode-update-file-info)
+ (if (motion-event-p event)
+ (set-extent-end-glyph
+ preview-extent (Wand:glyph-internal
+ preview-wand off-x off-y
+ (- pw off-x) (- ph off-y)))
+
+ ;; Button released
+ (setq mouse-down nil)
+ (put preview-wand 'offset-x off-x)
+ (put preview-wand 'offset-y off-y)))
+
+ (dispatch-event event)))))
(defun Wand-mode-crop ()
"Crop image to selected region."
(defun Wand-mode-preview-op (op)
"Preview some operation OP with 8 subnails."
(interactive (list (completing-read "Operation: "
- MagickPreviewType-completion-table nil t)))
+ MagickPreviewType-completion-table nil t)))
(Wand-redisplay (Wand-operation-apply 'preview-op image-wand op)))
(put 'Wand-mode-preview-op 'region-operation t)
(put 'Wand-mode-preview-op 'menu-name "Preview operation")
If FACTOR is nil, then `Wand-mode-zoom-factor' is used."
(interactive "P")
(Wand-operation-apply 'zoom image-wand nil
- (if factor
- (prefix-numeric-value factor)
- Wand-mode-zoom-factor))
+ (if factor
+ (prefix-numeric-value factor)
+ Wand-mode-zoom-factor))
(Wand-redisplay))
(defun Wand-mode-zoom-out (factor)
"Zoom image out by `Wand-mode-zoom-factor'."
(interactive "P")
(Wand-operation-apply 'zoom image-wand t
- (if factor
- (prefix-numeric-value factor)
- Wand-mode-zoom-factor))
+ (if factor
+ (prefix-numeric-value factor)
+ Wand-mode-zoom-factor))
(Wand-redisplay))
(defun Wand-mode-sample (w h)
"Sample image to WxH size."
(interactive
(list (read-number (format "Width [%d]: " (Wand:image-width image-wand))
- t (int-to-string (Wand:image-width image-wand)))
- (read-number (format "Height [%d]: " (Wand:image-height image-wand))
- t (int-to-string (Wand:image-height image-wand)))))
+ t (int-to-string (Wand:image-width image-wand)))
+ (read-number (format "Height [%d]: " (Wand:image-height image-wand))
+ t (int-to-string (Wand:image-height image-wand)))))
(Wand-operation-apply 'sample image-wand w h)
(Wand-redisplay))
(put 'Wand-mode-sample 'transform-operation t)
"Resize image to fit into WxH size."
(interactive
(let* ((dw (read-number
- (format "Width [%d]: " (Wand:image-width image-wand))
- t (int-to-string (Wand:image-width image-wand))))
- (dh (round (* (Wand:image-height image-wand)
- (// dw (Wand:image-width image-wand))))))
+ (format "Width [%d]: " (Wand:image-width image-wand))
+ t (int-to-string (Wand:image-width image-wand))))
+ (dh (round (* (Wand:image-height image-wand)
+ (// dw (Wand:image-width image-wand))))))
(list dw (read-number (format "Height [%d]: " dh)
- t (int-to-string dh)))))
-
+ t (int-to-string dh)))))
+
(Wand-operation-apply 'fit-size image-wand w h)
(Wand-redisplay))
(put 'Wand-mode-fit-size 'transform-operation t)
"Rescale image to WxH using liquid rescale."
(interactive
(list (read-number (format "Width [%d]: " (Wand:image-width image-wand))
- t (int-to-string (Wand:image-width image-wand)))
- (read-number (format "Height [%d]: " (Wand:image-height image-wand))
- t (int-to-string (Wand:image-height image-wand)))))
+ t (int-to-string (Wand:image-width image-wand)))
+ (read-number (format "Height [%d]: " (Wand:image-height image-wand))
+ t (int-to-string (Wand:image-height image-wand)))))
(Wand-operation-apply 'liquid-rescale image-wand w h)
(Wand-redisplay))
(put 'Wand-mode-liquid-rescale 'transform-operation t)
(defun Wand-mode-pattern (pattern &optional op)
"Enable checkerboard as tile background."
(interactive (list (completing-read "Pattern: " Wand-patterns nil t)
- (if current-prefix-arg
- (completing-read "Composite Op: "
- WandCompositeOperator-completion-table nil t)
- Wand-pattern-composite-op)))
+ (if current-prefix-arg
+ (completing-read "Composite Op: "
+ WandCompositeOperator-completion-table nil t)
+ Wand-pattern-composite-op)))
(Wand-operation-apply 'pattern image-wand pattern op)
(Wand-redisplay))
(put 'Wand-mode-pattern 'transform-operation t)
(Wand-with-drawing-wand d-out
(Wand-with-pixel-wand pw
- (setf (Wand:pixel-color pw) "blue")
- (setf (Wand:draw-fill-color d-out) pw))
+ (setf (Wand:pixel-color pw) "blue")
+ (setf (Wand:draw-fill-color d-out) pw))
(Wand:draw-rectangle d-out 10.0 0.0 42.0 32.0)
(Wand-with-wand w-out
- (setf (Wand:image-size w-out)
- (cons 80 (face-height 'default)))
- (Wand:MagickReadImage w-out "pattern:horizontal")
- (Wand:MagickDrawImage w-out d-out)
-
- (flet ((draw-in-out (cop)
- (Wand-with-wand w-in
- (setf (Wand:image-size w-in)
- (cons 80 (face-height 'default)))
- (Wand:MagickReadImage w-in "pattern:vertical")
- (Wand:MagickDrawImage w-in d-in)
- (Wand:image-composite w-in w-out (cdr cop) 0 0)
- (let ((pnt (point)))
- (insert " " (car cop) "\n")
- (set-extent-end-glyph
- (make-extent pnt pnt)
- (Wand:glyph w-in))))))
- (with-output-to-temp-buffer "*Wand-Composite-Ops*"
- (set-buffer standard-output)
- (mapc #'draw-in-out
- (cdr WandCompositeOperator-completion-table))))))))
+ (setf (Wand:image-size w-out)
+ (cons 80 (face-height 'default)))
+ (Wand:MagickReadImage w-out "pattern:horizontal")
+ (Wand:MagickDrawImage w-out d-out)
+
+ (flet ((draw-in-out (cop)
+ (Wand-with-wand w-in
+ (setf (Wand:image-size w-in)
+ (cons 80 (face-height 'default)))
+ (Wand:MagickReadImage w-in "pattern:vertical")
+ (Wand:MagickDrawImage w-in d-in)
+ (Wand:image-composite w-in w-out (cdr cop) 0 0)
+ (let ((pnt (point)))
+ (insert " " (car cop) "\n")
+ (set-extent-end-glyph
+ (make-extent pnt pnt)
+ (Wand:glyph w-in))))))
+ (with-output-to-temp-buffer "*Wand-Composite-Ops*"
+ (set-buffer standard-output)
+ (mapc #'draw-in-out
+ (cdr WandCompositeOperator-completion-table))))))))
(defun Wand-list-patterns ()
"Show available patterns in separate buffer.
(interactive)
(with-output-to-temp-buffer "*Wand-Patterns*"
(flet ((draw-pattern (pat-name)
- (let ((pnt (point)))
- (insert " " pat-name "\n")
- (set-extent-end-glyph
- (make-extent pnt pnt)
- (Wand-with-wand wand
- (setf (Wand:image-size wand)
- (cons 80 (face-height 'default)))
- (Wand:MagickReadImage wand (concat "pattern:" pat-name))
- (Wand:glyph wand))))))
+ (let ((pnt (point)))
+ (insert " " pat-name "\n")
+ (set-extent-end-glyph
+ (make-extent pnt pnt)
+ (Wand-with-wand wand
+ (setf (Wand:image-size wand)
+ (cons 80 (face-height 'default)))
+ (Wand:MagickReadImage wand (concat "pattern:" pat-name))
+ (Wand:glyph wand))))))
(save-excursion
- (set-buffer standard-output)
- (mapc #'draw-pattern (mapcar #'car Wand-patterns))))))
+ (set-buffer standard-output)
+ (mapc #'draw-pattern (mapcar #'car Wand-patterns))))))
(put 'Wand-list-patterns 'transform-operation t)
(put 'Wand-list-patterns 'menu-name "List Patterns")
(dotimes (n arg)
(let ((op (pop undo-list)))
(when op
- (apply #'Wand-operation-apply (car op) image-wand (cdr op)))))
+ (apply #'Wand-operation-apply (car op) image-wand (cdr op)))))
(Wand-redisplay)
(message "Redo!"))
(let ((last-op (car (last operations-list))))
(when last-op
(apply #'Wand-operation-apply
- (car last-op) image-wand (cdr last-op))
+ (car last-op) image-wand (cdr last-op))
(Wand-redisplay))))
(defun Wand-mode-global-operations-list (arg)
example zoom."
(interactive "P")
(setq Wand-global-operations-list
- (and (not arg) operations-list))
+ (and (not arg) operations-list))
(Wand-redisplay))
(defun Wand-mode-write-file (format nfile)
"Write file using output FORMAT."
(interactive
(let* ((ofmt (completing-read
- (format "Output Format [%s]: "
- (Wand:image-format image-wand))
- (mapcar #'list (Wand-formats-list "*" 'write))
- nil t nil nil (Wand:image-format image-wand)))
- (nfname (concat (file-name-sans-extension buffer-file-name)
- "." (downcase ofmt)))
- (fn (read-file-name
- "Filename: "
- (file-name-directory buffer-file-name)
- nfname nil (file-name-nondirectory nfname))))
+ (format "Output Format [%s]: "
+ (Wand:image-format image-wand))
+ (mapcar #'list (Wand-formats-list "*" 'write))
+ nil t nil nil (Wand:image-format image-wand)))
+ (nfname (concat (file-name-sans-extension buffer-file-name)
+ "." (downcase ofmt)))
+ (fn (read-file-name
+ "Filename: "
+ (file-name-directory buffer-file-name)
+ nfname nil (file-name-nondirectory nfname))))
(list ofmt fn)))
(unless (Wand-format-supported-for-write-p format)
(error "Unsupported format for writing: %s" format))
(when (or (not Wand-mode-query-for-overwrite)
- (not (file-exists-p nfile))
- (y-or-n-p (format "File %s exists, overwrite? " nfile)))
+ (not (file-exists-p nfile))
+ (y-or-n-p (format "File %s exists, overwrite? " nfile)))
(setf (Wand:image-format image-wand) format)
(let ((saved-iw image-wand)) ; do this because it is buffer-local
(with-temp-buffer
- (insert (Wand:image-blob saved-iw))
- (set-visited-file-name nfile t)
- (set-buffer-modified-p t)
- (setq buffer-read-only nil)
- (let ((buffer-file-coding-system (get-coding-system 'binary)))
- (save-buffer))))
+ (insert (Wand:image-blob saved-iw))
+ (set-visited-file-name nfile t)
+ (set-buffer-modified-p t)
+ (setq buffer-read-only nil)
+ (let ((buffer-file-coding-system (get-coding-system 'binary)))
+ (save-buffer))))
(message "File %s saved" nfile)
;; Redisplay in case we can do it
(if (Wand-format-supported-for-read-p format)
- (Wand-display nfile)
+ (Wand-display nfile)
(find-file nfile))))
(defun Wand-mode-save-file (nfile)
performed, use `Wand-mode-write-file' if are not sure."
(interactive
(list (read-file-name "Filename: "
- (file-name-directory buffer-file-name)
- buffer-file-name nil
- (file-name-nondirectory buffer-file-name))))
+ (file-name-directory buffer-file-name)
+ buffer-file-name nil
+ (file-name-nondirectory buffer-file-name))))
(Wand-mode-write-file
(upcase (file-name-extension nfile)) nfile))
"*If t, delete excess backup versions silently.
If nil, ask confirmation. Any other value prevents any trimming."
:type '(choice (const :tag "Delete" t)
- (const :tag "Ask" nil)
- (sexp :tag "Leave" :format "%t\n" other))
+ (const :tag "Ask" nil)
+ (sexp :tag "Leave" :format "%t\n" other))
:group 'backup)
(defcustom kept-old-versions 2
(let ((name (copy-sequence filename))
(start 0))
;; leave ':' if part of drive specifier
- (if (and (> (length name) 1)
- (eq (aref name 1) ?:))
+ (if (and (> (length name) 1)
+ (eq (aref name 1) ?:))
(setq start 2))
;; destructively replace invalid filename characters with !
(while (string-match "[?*:<>|\"\000-\037]" name start)
(setq dir (file-truename dir)))
(setq dir (abbreviate-file-name (expand-file-name dir)))
(cond ((not (file-directory-p dir))
- (error "%s is not a directory" dir))
+ (error "%s is not a directory" dir))
;; this breaks ange-ftp, which doesn't (can't?) overload `file-executable-p'.
- ;;((not (file-executable-p dir))
- ;; (error "Cannot cd to %s: Permission denied" dir))
- (t
- (setq default-directory dir))))
+ ;;((not (file-executable-p dir))
+ ;; (error "Cannot cd to %s: Permission denied" dir))
+ (t
+ (setq default-directory dir))))
(defun cd (dir)
"Make DIR become the current buffer's default directory.
(setq cd-path (or trypath (list "./")))))
(or (catch 'found
(mapcar #'(lambda (x)
- (let ((f (expand-file-name (concat x dir))))
+ (let ((f (expand-file-name (concat x dir))))
(if (file-directory-p f)
(progn
- (cd-absolute f)
- (throw 'found t)))))
+ (cd-absolute f)
+ (throw 'found t)))))
cd-path)
nil)
;; jwz: give a better error message to those of us with the
(save-excursion
(set-buffer (car list))
(if (and buffer-file-number
- (equal buffer-file-number number)
+ (equal buffer-file-number number)
;; Verify this buffer's file number
;; still belongs to its file.
(file-exists-p buffer-file-name)
"Try to use dired to open FILENAME, which is directory."
(if (and (fboundp 'dired-noselect) find-file-run-dired)
(dired-noselect (if find-file-use-truenames
- (abbreviate-file-name (file-truename filename))
- filename))
+ (abbreviate-file-name (file-truename filename))
+ filename))
(error "%s is a directory" filename)))
(defun find-file-find-magic (filename)
"Find entry in `find-file-magic-files-alist' that matches FILENAME."
(find filename find-file-magic-files-alist :key #'car
- :test #'(lambda (fn predicate)
- (funcall predicate fn))))
+ :test #'(lambda (fn predicate)
+ (funcall predicate fn))))
(defun find-file-noselect (filename &optional nowarn rawfile)
"Read file FILENAME into a buffer and return the buffer.
;; Try magic files first
(let ((mfa-item (find-file-find-magic filename)))
(if mfa-item
- (funcall (cdr mfa-item) filename)
+ (funcall (cdr mfa-item) filename)
(let* ((buf (get-file-buffer filename))
- (truename (abbreviate-file-name (file-truename filename)))
- (number (nthcdr 10 (file-attributes truename)))
+ (truename (abbreviate-file-name (file-truename filename)))
+ (number (nthcdr 10 (file-attributes truename)))
; ;; Find any buffer for a file which has same truename.
; (other (and (not buf) (find-buffer-visiting filename)))
- (error nil))
+ (error nil))
; ;; Let user know if there is a buffer with the same truename.
; (if (and (not buf) same-truename (not nowarn))
; (if (or find-file-existing-other-name find-file-visit-truename)
; (setq buf (or same-truename same-number)))
- (when (and buf
- (or find-file-compare-truenames find-file-use-truenames)
- (not nowarn))
- (save-excursion
- (set-buffer buf)
- (if (not (string-equal buffer-file-name filename))
- (message "%s and %s are the same file (%s)"
- filename buffer-file-name
- buffer-file-truename))))
-
- (if buf
- (or nowarn
- (verify-visited-file-modtime buf)
- (cond ((not (file-exists-p filename))
- (error "File %s no longer exists!" filename))
- ;; Certain files should be reverted automatically
- ;; if they have changed on disk and not in the buffer.
- ((and (not (buffer-modified-p buf))
- (dolist (rx revert-without-query nil)
- (when (string-match rx filename)
- (return t))))
- (with-current-buffer buf
- (message "Reverting file %s..." filename)
- (revert-buffer t t)
- (message "Reverting file %s... done" filename)))
- ((yes-or-no-p
- (if (string= (file-name-nondirectory filename)
- (buffer-name buf))
- (format
- (if (buffer-modified-p buf)
- (gettext "File %s changed on disk. Discard your edits? ")
- (gettext "File %s changed on disk. Reread from disk? "))
- (file-name-nondirectory filename))
- (format
- (if (buffer-modified-p buf)
- (gettext "File %s changed on disk. Discard your edits in %s? ")
- (gettext "File %s changed on disk. Reread from disk into %s? "))
- (file-name-nondirectory filename)
- (buffer-name buf))))
- (with-current-buffer buf
- (revert-buffer t t)))))
- ;; Else: we must create a new buffer for filename
- (save-excursion
+ (when (and buf
+ (or find-file-compare-truenames find-file-use-truenames)
+ (not nowarn))
+ (save-excursion
+ (set-buffer buf)
+ (if (not (string-equal buffer-file-name filename))
+ (message "%s and %s are the same file (%s)"
+ filename buffer-file-name
+ buffer-file-truename))))
+
+ (if buf
+ (or nowarn
+ (verify-visited-file-modtime buf)
+ (cond ((not (file-exists-p filename))
+ (error "File %s no longer exists!" filename))
+ ;; Certain files should be reverted automatically
+ ;; if they have changed on disk and not in the buffer.
+ ((and (not (buffer-modified-p buf))
+ (dolist (rx revert-without-query nil)
+ (when (string-match rx filename)
+ (return t))))
+ (with-current-buffer buf
+ (message "Reverting file %s..." filename)
+ (revert-buffer t t)
+ (message "Reverting file %s... done" filename)))
+ ((yes-or-no-p
+ (if (string= (file-name-nondirectory filename)
+ (buffer-name buf))
+ (format
+ (if (buffer-modified-p buf)
+ (gettext "File %s changed on disk. Discard your edits? ")
+ (gettext "File %s changed on disk. Reread from disk? "))
+ (file-name-nondirectory filename))
+ (format
+ (if (buffer-modified-p buf)
+ (gettext "File %s changed on disk. Discard your edits in %s? ")
+ (gettext "File %s changed on disk. Reread from disk into %s? "))
+ (file-name-nondirectory filename)
+ (buffer-name buf))))
+ (with-current-buffer buf
+ (revert-buffer t t)))))
+ ;; Else: we must create a new buffer for filename
+ (save-excursion
;;; The truename stuff makes this obsolete.
;;; (let* ((link-name (car (file-attributes filename)))
;;; (linked-buf (and (stringp link-name)
;;; (if (bufferp linked-buf)
;;; (message "Symbolic link to file in buffer %s"
;;; (buffer-name linked-buf))))
- (setq buf (create-file-buffer filename))
- ;; Catch various signals, such as QUIT, and kill the buffer
- ;; in that case.
- (condition-case data
- (progn
- (set-buffer-major-mode buf)
- (set-buffer buf)
- (erase-buffer)
- (condition-case ()
- (if rawfile
- (insert-file-contents-literally filename t)
- (insert-file-contents filename t))
- (file-error
- (when (and (file-exists-p filename)
- (not (file-readable-p filename)))
- (signal 'file-error (list "File is not readable" filename)))
- (if rawfile
- ;; Unconditionally set error
- (setq error t)
- (or
- ;; Run find-file-not-found-hooks until one returns non-nil.
- (run-hook-with-args-until-success 'find-file-not-found-hooks)
- ;; If they fail too, set error.
- (setq error t)))))
- ;; Find the file's truename, and maybe use that as visited name.
- ;; automatically computed in XEmacs, unless jka-compr was used!
- (unless buffer-file-truename
- (setq buffer-file-truename truename))
- (setq buffer-file-number number)
- (and find-file-use-truenames
- ;; This should be in C. Put pathname
- ;; abbreviations that have been explicitly
- ;; requested back into the pathname. Most
- ;; importantly, strip out automounter /tmp_mnt
- ;; directories so that auto-save will work
- (setq buffer-file-name (abbreviate-file-name buffer-file-name)))
- ;; Set buffer's default directory to that of the file.
- (setq default-directory (file-name-directory buffer-file-name))
- ;; Turn off backup files for certain file names. Since
- ;; this is a permanent local, the major mode won't eliminate it.
- (and (not (funcall backup-enable-predicate buffer-file-name))
- (progn
- (make-local-variable 'backup-inhibited)
- (setq backup-inhibited t)))
- (if rawfile
- ;; #### FSF 20.3 sets buffer-file-coding-system to
- ;; `no-conversion' here. Should we copy? It also
- ;; makes `find-file-literally' a local variable
- ;; and sets it to t.
- nil
- (after-find-file error (not nowarn))
- (setq buf (current-buffer))))
- (t
- (kill-buffer buf)
- (signal (car data) (cdr data))))
- ))
- buf))))
+ (setq buf (create-file-buffer filename))
+ ;; Catch various signals, such as QUIT, and kill the buffer
+ ;; in that case.
+ (condition-case data
+ (progn
+ (set-buffer-major-mode buf)
+ (set-buffer buf)
+ (erase-buffer)
+ (condition-case ()
+ (if rawfile
+ (insert-file-contents-literally filename t)
+ (insert-file-contents filename t))
+ (file-error
+ (when (and (file-exists-p filename)
+ (not (file-readable-p filename)))
+ (signal 'file-error (list "File is not readable" filename)))
+ (if rawfile
+ ;; Unconditionally set error
+ (setq error t)
+ (or
+ ;; Run find-file-not-found-hooks until one returns non-nil.
+ (run-hook-with-args-until-success 'find-file-not-found-hooks)
+ ;; If they fail too, set error.
+ (setq error t)))))
+ ;; Find the file's truename, and maybe use that as visited name.
+ ;; automatically computed in XEmacs, unless jka-compr was used!
+ (unless buffer-file-truename
+ (setq buffer-file-truename truename))
+ (setq buffer-file-number number)
+ (and find-file-use-truenames
+ ;; This should be in C. Put pathname
+ ;; abbreviations that have been explicitly
+ ;; requested back into the pathname. Most
+ ;; importantly, strip out automounter /tmp_mnt
+ ;; directories so that auto-save will work
+ (setq buffer-file-name (abbreviate-file-name buffer-file-name)))
+ ;; Set buffer's default directory to that of the file.
+ (setq default-directory (file-name-directory buffer-file-name))
+ ;; Turn off backup files for certain file names. Since
+ ;; this is a permanent local, the major mode won't eliminate it.
+ (and (not (funcall backup-enable-predicate buffer-file-name))
+ (progn
+ (make-local-variable 'backup-inhibited)
+ (setq backup-inhibited t)))
+ (if rawfile
+ ;; #### FSF 20.3 sets buffer-file-coding-system to
+ ;; `no-conversion' here. Should we copy? It also
+ ;; makes `find-file-literally' a local variable
+ ;; and sets it to t.
+ nil
+ (after-find-file error (not nowarn))
+ (setq buf (current-buffer))))
+ (t
+ (kill-buffer buf)
+ (signal (car data) (cdr data))))
+ ))
+ buf))))
\f
;; FSF has `insert-file-literally' and `find-file-literally' here.
(signal 'quit nil))))
nil))))
(when msg
- (message "%s" msg)
- (unless not-serious
- (save-excursion (sit-for 1 t)))))
+ (message "%s" msg)
+ (unless not-serious
+ (save-excursion (sit-for 1 t)))))
(if (and auto-save-default (not noauto))
(auto-save-mode t)))
(unless nomodes
(interactive)
(or find-file (funcall (or default-major-mode 'fundamental-mode)))
(and (condition-case err
- (progn (set-auto-mode)
- t)
- (error (message "File mode specification error: %s"
- (prin1-to-string err))
- nil))
+ (progn (set-auto-mode)
+ t)
+ (error (message "File mode specification error: %s"
+ (prin1-to-string err))
+ nil))
(condition-case err
- (hack-local-variables (not find-file))
- (error (lwarn 'local-variables 'warning
+ (hack-local-variables (not find-file))
+ (error (lwarn 'local-variables 'warning
"File local-variables error: %s"
(error-message-string err))))))
;(eval-when-compile
; (require 'regexp-opt)
; (list
-; (format "\\.\\(?:%s\\)\\'"
+; (format "\\.\\(?:%s\\)\\'"
; (regexp-opt
; '(
; ;; Compressed files
; "7Z" "7z" "ARC" "EAR" "JAR" "LZH" "RAR" "WAR"
-; "XPI" "Z" "ZIP" "ZOO" "arc" "bz2" "ear" "gz"
+; "XPI" "Z" "ZIP" "ZOO" "arc" "bz2" "ear" "gz"
; "jar" "tar" "tgz" "tiff" "war" "xpi" "zip" "zoo"
; "zoo" "lha" "lzh" "lzma" "xz"
; ;; Code
;; this buffer isn't associated with a file.
(null buffer-file-name)
(let ((name (file-name-sans-versions buffer-file-name))
- (keep-going t))
- (while keep-going
- (setq keep-going nil)
- (let ((alist auto-mode-alist)
- (mode nil))
+ (keep-going t))
+ (while keep-going
+ (setq keep-going nil)
+ (let ((alist auto-mode-alist)
+ (mode nil))
- ;; Find first matching alist entry.
+ ;; Find first matching alist entry.
;; #### This is incorrect. In NT, case sensitivity is a volume
;; property. For instance, NFS mounts *are* case sensitive.
(setq mode (cdr (car alist)))
(setq alist nil))
(setq alist (cdr alist)))))))
- (if mode
+ (if mode
(if (not (fboundp mode))
- (let ((name (declare-fboundp (package-get-package-provider mode))))
- (if name
- (message "Mode %s is not installed. Download package %s" mode name)
- (message "Mode %s either doesn't exist or is not a known package" mode))
- (sit-for 2)
- (error "%s" mode))
+ (let ((name (declare-fboundp (package-get-package-provider mode))))
+ (if name
+ (message "Mode %s is not installed. Download package %s" mode name)
+ (message "Mode %s either doesn't exist or is not a known package" mode))
+ (sit-for 2)
+ (error "%s" mode))
(unless (and just-from-file-name
(or
;; Don't reinvoke major mode.
(setq temp (cdr temp))
temp))))
(progn
- ;; Look for variables in the -*- line.
- (hack-local-variables-prop-line force)
- ;; Look for "Local variables:" block in last page.
- (hack-local-variables-last-page force)))
+ ;; Look for variables in the -*- line.
+ (hack-local-variables-prop-line force)
+ ;; Look for "Local variables:" block in last page.
+ (hack-local-variables-last-page force)))
(run-hooks 'hack-local-variables-hook))
;;; Local variables may be specified in the last page of the file (within 3k
(defun hack-local-variables-p (modeline)
(or (eq enable-local-variables t)
(and enable-local-variables
- (save-window-excursion
- (condition-case nil
- (switch-to-buffer (current-buffer))
- (error
- ;; If we fail to switch in the selected window,
- ;; it is probably a minibuffer.
- ;; So try another window.
- (condition-case nil
- (switch-to-buffer-other-window (current-buffer))
- (error
- (switch-to-buffer-other-frame (current-buffer))))))
- (or modeline (save-excursion
- (beginning-of-line)
- (set-window-start (selected-window) (point))))
- (y-or-n-p (format
- "Set local variables as specified %s of %s? "
- (if modeline "in -*- line" "at end")
- (if buffer-file-name
- (file-name-nondirectory buffer-file-name)
- (concat "buffer " (buffer-name)))))))))
+ (save-window-excursion
+ (condition-case nil
+ (switch-to-buffer (current-buffer))
+ (error
+ ;; If we fail to switch in the selected window,
+ ;; it is probably a minibuffer.
+ ;; So try another window.
+ (condition-case nil
+ (switch-to-buffer-other-window (current-buffer))
+ (error
+ (switch-to-buffer-other-frame (current-buffer))))))
+ (or modeline (save-excursion
+ (beginning-of-line)
+ (set-window-start (selected-window) (point))))
+ (y-or-n-p (format
+ "Set local variables as specified %s of %s? "
+ (if modeline "in -*- line" "at end")
+ (if buffer-file-name
+ (file-name-nondirectory buffer-file-name)
+ (concat "buffer " (buffer-name)))))))))
(defun hack-local-variables-last-page (&optional force)
;; Set local variables set in the "Local Variables:" block of the last page.
(if (let ((case-fold-search t))
(and (search-forward "Local Variables:" nil t)
(or force
- (hack-local-variables-p nil))))
+ (hack-local-variables-p nil))))
(let ((continue t)
prefix prefixlen suffix start
- (enable-local-eval enable-local-eval))
+ (enable-local-eval enable-local-eval))
;; The prefix is what comes before "local variables:" in its line.
;; The suffix is what comes after "local variables:" in its line.
(skip-chars-forward " \t")
(or (if suffix (looking-at suffix) (eolp))
(error "Local variables entry is terminated incorrectly"))
;; Set the variable. "Variables" mode and eval are funny.
- (hack-one-local-variable var val))))))))
+ (hack-one-local-variable var val))))))))
;; jwz - New Version 20.1/19.15
(defun hack-local-variables-prop-line (&optional force)
(save-match-data
(let ((file (file-name-sans-versions (file-name-nondirectory filename))))
(if (string-match #r"\.[^.]*\'" file)
- (substring file (+ (match-beginning 0) (if period 0 1)))
- (if period
- "")))))
+ (substring file (+ (match-beginning 0) (if period 0 1)))
+ (if period
+ "")))))
(defun make-backup-file-name (file)
"Create the non-numeric backup file name for FILE.
;; outermost call).
;;
;; Ugh, have to duplicate logic of run-hook-with-args-until-success
- (let ((hooks (append (files-fetch-hook-value 'write-contents-hooks)
- (files-fetch-hook-value
+ (let ((hooks (append (files-fetch-hook-value 'write-contents-hooks)
+ (files-fetch-hook-value
'local-write-file-hooks)
- (files-fetch-hook-value 'write-file-hooks)))
+ (files-fetch-hook-value 'write-file-hooks)))
(after-save-hook nil)
- (local-write-file-hooks nil)
+ (local-write-file-hooks nil)
(write-contents-hooks nil)
(write-file-hooks nil)
done)
- (while (and hooks
- (let ((continue-save-buffer-hooks-tail hooks))
- (not (setq done (funcall (car hooks))))))
- (setq hooks (cdr hooks)))
+ (while (and hooks
+ (let ((continue-save-buffer-hooks-tail hooks))
+ (not (setq done (funcall (car hooks))))))
+ (setq hooks (cdr hooks)))
;; If a hook returned t, file is already "written".
;; Otherwise, write it the usual way now.
(if (not done)
(interactive "_P")
(setq buffer-read-only
(if (null arg)
- (not buffer-read-only)
- (> (prefix-numeric-value arg) 0)))
+ (not buffer-read-only)
+ (> (prefix-numeric-value arg) 0)))
;; Force modeline redisplay
(redraw-modeline))
(found nil)
(delay-prompt nil)
(auto-save-p (and (not ignore-auto)
- (recent-auto-save-p)
+ (recent-auto-save-p)
buffer-auto-save-file-name
(file-readable-p buffer-auto-save-file-name)
(y-or-n-p
;; ... and if different, prompt
(or noconfirm found
(and delay-prompt
- (yes-or-no-p
+ (yes-or-no-p
(format "Revert buffer from file %s? "
file-name))))))
;; If file was backed up but has changed since,
bmax (point-max))))))
(if (not (and (eq bmin (point-min))
(eq bmax (point-max))
- (eq (compare-buffer-substrings
+ (eq (compare-buffer-substrings
newbuf bmin bmax (current-buffer) bmin bmax) 0)))
newbuf
(and (kill-buffer newbuf) nil))))
With prefix argument ARG, turn auto-saving on if positive, else off."
(interactive "P")
(setq buffer-auto-save-file-name
- (and (if (null arg)
+ (and (if (null arg)
(or (not buffer-auto-save-file-name)
;; If autosave is off because buffer has shrunk,
;; then toggling should turn it on.
;; File lines should display the basename.
;; - must be consistent with
;; - functions dired-move-to-filename, (these two define what a file line is)
-;; dired-move-to-end-of-filename,
+;; dired-move-to-end-of-filename,
;; dired-between-files, (shortcut for (not (dired-move-to-filename)))
-;; dired-insert-headerline
-;; dired-after-subdir-garbage (defines what a "total" line is)
+;; dired-insert-headerline
+;; dired-after-subdir-garbage (defines what a "total" line is)
;; - variable dired-subdir-regexp
(defun insert-directory (file switches &optional wildcard full-directory-p)
"Insert directory listing for FILE, formatted according to SWITCHES.
;; end patch
(goto-char from)
(skip-chars-forward " \t")
- (if (and nosqueeze (not (eq justify 'full)))
+ (if (and nosqueeze (not (eq justify 'full)))
nil
(canonically-space-region (or squeeze-after (point)) (point-max))
(goto-char (point-max))
(looking-at "[ \t]*$")))
(if (looking-at "[ \t]*[^ \t\n]+:")
(search-forward "\n\n" nil 'move)
- (forward-line 1))))
+ (forward-line 1))))
(narrow-to-region (point) max)
;; Loop over paragraphs.
(while (progn (skip-chars-forward " \t\n") (not (eobp)))
(progn
(forward-char (length fill-prefix))
(looking-at paragraph-separate))))))
- ;; If this line has more or less indent
- ;; than the fill prefix wants, end the paragraph.
- (and (looking-at fill-prefix-regexp)
- (save-excursion
- (not
+ ;; If this line has more or less indent
+ ;; than the fill prefix wants, end the paragraph.
+ (and (looking-at fill-prefix-regexp)
+ (save-excursion
+ (not
(progn
(forward-char (length fill-prefix))
(or (looking-at paragraph-separate)
;; inplace
(and
(paths-file-readable-directory-p (paths-construct-path
- (list directory "lisp")))
+ (list directory "lisp")))
(paths-file-readable-directory-p (paths-construct-path
- (list directory "etc"))))))
+ (list directory "etc"))))))
(defun paths-root-in-place-p (root)
"Check if ROOT is an in-place installation root for XEmacs."
(defun paths-find-emacs-directory (roots suffix base
&optional envvar default keep-suffix
- in-place-external)
+ in-place-external)
"Find a directory in the XEmacs hierarchy.
ROOTS must be a list of installation roots.
SUFFIX is the subdirectory from there.
;; look for lib/sxemacs-xx.y.z
;; what do we do if user specifies --libdir?
(paths-find-emacs-directory roots
- (file-name-as-directory
- (paths-construct-path
- (list "lib"
- (construct-emacs-version-name))))
- base
- envvar default
- enforce-version))
+ (file-name-as-directory
+ (paths-construct-path
+ (list "lib"
+ (construct-emacs-version-name))))
+ base
+ envvar default
+ enforce-version))
(defun paths-find-version-archindep-directory
(roots base &optional envvar default enforce-version)
If ENFORCE-VERSION is non-nil, the directory must contain the SXEmacs version."
;; look for share/sxemacs-xx.y.z
(paths-find-emacs-directory roots
- (file-name-as-directory
- (paths-construct-path
- (list "share"
- (construct-emacs-version-name))))
- base
- envvar default
- enforce-version))
+ (file-name-as-directory
+ (paths-construct-path
+ (list "share"
+ (construct-emacs-version-name))))
+ base
+ envvar default
+ enforce-version))
;; we default to the arch-independent directory atm
(defalias 'path-find-version-directory #'paths-find-version-archindep-directory)
(or
;; from more to less specific
(paths-find-version-archdep-directory roots
- (paths-construct-path
- (list system-configuration base))
- envvar default)
+ (paths-construct-path
+ (list system-configuration base))
+ envvar default)
(paths-find-version-archdep-directory roots
- base
- envvar)
+ base
+ envvar)
(paths-find-version-archdep-directory roots
- system-configuration
- envvar)))
+ system-configuration
+ envvar)))
(defun construct-emacs-version-name ()
"Construct the raw XEmacs version number."
"Find all plausible installation roots for SXEmacs."
(let* ((potential-invocation-root
(paths-find-emacs-root
- invocation-directory invocation-name))
+ invocation-directory invocation-name))
(invocation-roots nil)
(potential-installation-roots
- (when (null dumpp)
- (paths-uniq-append
- (and configure-exec-prefix-directory
- (list (file-name-as-directory
- configure-exec-prefix-directory)))
- (and configure-prefix-directory
- (list (file-name-as-directory
- configure-prefix-directory))))))
+ (when (null dumpp)
+ (paths-uniq-append
+ (and configure-exec-prefix-directory
+ (list (file-name-as-directory
+ configure-exec-prefix-directory)))
+ (and configure-prefix-directory
+ (list (file-name-as-directory
+ configure-prefix-directory))))))
(installation-roots
(paths-filter #'paths-emacs-root-p potential-installation-roots))
- (source-tree-root
- (or (getenv "SOURCE_TREE_ROOT")
- (and potential-invocation-root
- (file-exists-p
- (expand-file-name ".sxemacs.source.tree"
- potential-invocation-root))
- (file-truename
- (expand-file-name ".sxemacs.source.tree"
- potential-invocation-root)))))
- (build-tree-root
- (getenv "BUILD_TREE_ROOT")))
+ (source-tree-root
+ (or (getenv "SOURCE_TREE_ROOT")
+ (and potential-invocation-root
+ (file-exists-p
+ (expand-file-name ".sxemacs.source.tree"
+ potential-invocation-root))
+ (file-truename
+ (expand-file-name ".sxemacs.source.tree"
+ potential-invocation-root)))))
+ (build-tree-root
+ (getenv "BUILD_TREE_ROOT")))
(when source-tree-root
(setq invocation-roots (cons source-tree-root invocation-roots)
invocation-roots (cons (or configure-prefix-directory
;; library directory names in finder-program-info, for fast display of
;; Lisp libraries and associated commentaries. Added {v}, finder-view,
;; and {e}, finder-edit commands for displaying libraries.
-;;
+;;
;; Added user variable, 'finder-abbreviate-directory-list', used to
;; abbreviate directories before they are saved to finder-program-info.
;; Such relative directories can be portable from one Emacs installation
(let ((processed nil)
(directory-abbrev-alist
(append
- (mapcar (function (lambda (dir)
- (cons (concat "^" (regexp-quote dir))
- "")))
+ (mapcar (function (lambda (dir)
+ (cons (concat "^" (regexp-quote dir))
+ "")))
finder-abbreviate-directory-list)
directory-abbrev-alist))
(using-load-path))
(mapcar
(lambda (d)
(mapcar
- (lambda (f)
- (let ((exhau-f (expand-file-name f d)))
- (when (and (not (member f processed))
- (file-readable-p exhau-f))
- (let (summary keystart keywords)
- (setq processed (cons f processed))
- (if (not finder-compile-keywords-quiet)
- (message "Processing %s ..." f))
- (save-excursion
- (set-buffer (get-buffer-create "*finder-scratch*"))
- (buffer-disable-undo (current-buffer))
- (erase-buffer)
- (insert-file-contents (expand-file-name f d))
- (condition-case err
- (setq summary (lm-synopsis)
- keywords (lm-keywords))
- (t (message "finder: error processing %s %S" f err))))
- (when summary
- (insert (format " (\"%s\"\n " f))
- (prin1 summary (current-buffer))
- (insert "\n ")
- (setq keystart (point))
- (insert (if keywords (format "(%s)" keywords) "nil"))
- (subst-char-in-region keystart (point) ?, ? )
- (insert "\n ")
- (prin1 (abbreviate-file-name d) (current-buffer))
- (insert ")\n"))))))
+ (lambda (f)
+ (let ((exhau-f (expand-file-name f d)))
+ (when (and (not (member f processed))
+ (file-readable-p exhau-f))
+ (let (summary keystart keywords)
+ (setq processed (cons f processed))
+ (if (not finder-compile-keywords-quiet)
+ (message "Processing %s ..." f))
+ (save-excursion
+ (set-buffer (get-buffer-create "*finder-scratch*"))
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (insert-file-contents (expand-file-name f d))
+ (condition-case err
+ (setq summary (lm-synopsis)
+ keywords (lm-keywords))
+ (t (message "finder: error processing %s %S" f err))))
+ (when summary
+ (insert (format " (\"%s\"\n " f))
+ (prin1 summary (current-buffer))
+ (insert "\n ")
+ (setq keystart (point))
+ (insert (if keywords (format "(%s)" keywords) "nil"))
+ (subst-char-in-region keystart (point) ?, ? )
+ (insert "\n ")
+ (prin1 (abbreviate-file-name d) (current-buffer))
+ (insert ")\n"))))))
;;
;; Skip null, non-existent or relative pathnames, e.g. "./", if
;; using load-path, so that they do not interfere with a scan of
(= (preceding-char) ?\t))
(let (indent-tabs-mode)
(delete-char -1)
- (indent-to col)
- (move-to-column column)))))
+ (indent-to col)
+ (move-to-column column)))))
(apply 'insert strings))
(defun finder-list-keywords ()
;; string of the variable `font-lock-keywords' for the appropriate syntax.
;;
;; The default value for `lisp-font-lock-keywords' is the value of the variable
-;; `lisp-font-lock-keywords-1'. You may like `lisp-font-lock-keywords-2'
+;; `lisp-font-lock-keywords-1'. You may like `lisp-font-lock-keywords-2'
;; better; it highlights many more words, but is slower and makes your buffers
;; be very visually noisy.
;;
;; doesn't work. Or maybe it allows you to think less and drift off to sleep.
;;
;; So, here are my opinions/advice/guidelines:
-;;
+;;
;; - Use the same face for the same conceptual object, across all modes.
;; i.e., (b) above, all modes that have items that can be thought of as, say,
;; keywords, should be highlighted with the same face, etc.
FONT-LOCK-KEYWORDS := List of FONT-LOCK-FORM's.
FONT-LOCK-FORM :== MATCHER
- | (MATCHER . MATCH)
- | (MATCHER . FACE-FORM)
- | (MATCHER . HIGHLIGHT)
- | (MATCHER HIGHLIGHT ...)
- | (eval . FORM)
+ | (MATCHER . MATCH)
+ | (MATCHER . FACE-FORM)
+ | (MATCHER . HIGHLIGHT)
+ | (MATCHER HIGHLIGHT ...)
+ | (eval . FORM)
MATCHER :== A string containing a regexp.
- | A variable containing a regexp to search for.
- | A function to call to make the search.
- It is called with one arg, the limit of the search,
- and should leave MATCH results in the XEmacs global
- match data.
+ | A variable containing a regexp to search for.
+ | A function to call to make the search.
+ It is called with one arg, the limit of the search,
+ and should leave MATCH results in the XEmacs global
+ match data.
MATCH :== An integer match subexpression number from MATCHER.
FACE-FORM :== The symbol naming a defined face.
- | Expression whos value is the face name to use. If you
- want FACE-FORM to be a symbol that evaluates to a face,
- use a form like \"(progn sym)\".
+ | Expression whos value is the face name to use. If you
+ want FACE-FORM to be a symbol that evaluates to a face,
+ use a form like \"(progn sym)\".
HIGHLIGHT :== MATCH-HIGHLIGHT
- | MATCH-ANCHORED
+ | MATCH-ANCHORED
FORM :== Expression returning a FONT-LOCK-FORM, evaluated when
- the FONT-LOCK-FORM is first used in a buffer. This
- feature can be used to provide a FONT-LOCK-FORM that
- can only be generated when Font Lock mode is actually
- turned on.
+ the FONT-LOCK-FORM is first used in a buffer. This
+ feature can be used to provide a FONT-LOCK-FORM that
+ can only be generated when Font Lock mode is actually
+ turned on.
MATCH-HIGHLIGHT :== (MATCH FACE-FORM OVERRIDE LAXMATCH)
OVERRIDE :== t - overwrite existing fontification
- | 'keep - only parts not already fontified are
- highlighted.
- | 'prepend - merge faces, this fontification has
- precedence over existing
- | 'append - merge faces, existing fontification has
- precedence over
- this face.
+ | 'keep - only parts not already fontified are
+ highlighted.
+ | 'prepend - merge faces, this fontification has
+ precedence over existing
+ | 'append - merge faces, existing fontification has
+ precedence over
+ this face.
LAXMATCH :== If non-nil, no error is signalled if there is no MATCH
- in MATCHER.
+ in MATCHER.
MATCH-ANCHORED :== (ANCHOR-MATCHER PRE-MATCH-FORM \\
- POST-MATCH-FORM MATCH-HIGHLIGHT ...)
+ POST-MATCH-FORM MATCH-HIGHLIGHT ...)
ANCHOR-MATCHER :== Like a MATCHER, except that the limit of the search
- defaults to the end of the line after PRE-MATCH-FORM
- is evaluated. However, if PRE-MATCH-FORM returns a
- position greater than the end of the line, that
- position is used as the limit of the search. It is
- generally a bad idea to return a position greater than
- the end of the line, i.e., cause the ANCHOR-MATCHER
- search to span lines.
+ defaults to the end of the line after PRE-MATCH-FORM
+ is evaluated. However, if PRE-MATCH-FORM returns a
+ position greater than the end of the line, that
+ position is used as the limit of the search. It is
+ generally a bad idea to return a position greater than
+ the end of the line, i.e., cause the ANCHOR-MATCHER
+ search to span lines.
PRE-MATCH-FORM :== Evaluated before the ANCHOR-MATCHER is used, therefore
- can be used to initialize before, ANCHOR-MATCHER is
- used. Typically, PRE-MATCH-FORM is used to move to
- some position relative to the original MATCHER, before
- starting with the ANCHOR-MATCHER.
+ can be used to initialize before, ANCHOR-MATCHER is
+ used. Typically, PRE-MATCH-FORM is used to move to
+ some position relative to the original MATCHER, before
+ starting with the ANCHOR-MATCHER.
POST-MATCH-FORM :== Like PRE-MATCH-FORM, but used to clean up after the
- ANCHOR-MATCHER. It might be used to move, before
- resuming with MATCH-ANCHORED's parent's MATCHER.
+ ANCHOR-MATCHER. It might be used to move, before
+ resuming with MATCH-ANCHORED's parent's MATCHER.
For example, an element of the first form highlights (if not already highlighted):
\"\\\\\\=<foo\\\\\\=>\" Discrete occurrences of \"foo\" in the value
- of the variable `font-lock-keyword-face'.
+ of the variable `font-lock-keyword-face'.
(\"fu\\\\(bar\\\\)\" . 1) Substring \"bar\" within all occurrences of
- \"fubar\" in the value of
- `font-lock-keyword-face'.
+ \"fubar\" in the value of
+ `font-lock-keyword-face'.
(\"fubar\" . fubar-face) Occurrences of \"fubar\" in the value of
- `fubar-face'.
+ `fubar-face'.
(\"foo\\\\|bar\" 0 foo-bar-face t) Occurrences of either \"foo\" or \"bar\" in the
- value of `foo-bar-face', even if already
- highlighted.
+ value of `foo-bar-face', even if already
+ highlighted.
(fubar-match 1 fubar-face) The first subexpression within all
- occurrences of whatever the function
- `fubar-match' finds and matches in the value
- of `fubar-face'.
+ occurrences of whatever the function
+ `fubar-match' finds and matches in the value
+ of `fubar-face'.
(\"\\\\\\=<anchor\\\\\\=>\" (0 anchor-face) (\"\\\\\\=<item\\\\\\=>\" nil nil (0 item-face)))
-------------- --------------- ------------ --- --- -------------
| | | | | |
MATCHER | ANCHOR-MATCHER | +------+ MATCH-HIGHLIGHT
- MATCH-HIGHLIGHT PRE-MATCH-FORM |
- POST-MATCH-FORM
+ MATCH-HIGHLIGHT PRE-MATCH-FORM |
+ POST-MATCH-FORM
Discrete occurrences of \"anchor\" in the value of `anchor-face', and
subsequent discrete occurrences of \"item\" (on the same line) in the value
(defvar font-lock-warning-face 'font-lock-warning-face
"This variable should not be set.
It is present only for reasons of backwards compatibility.
-The corresponding face should be set using `edit-faces' or the
+The corresponding face should be set using `edit-faces' or the
`set-face-*' functions.")
(defvar font-lock-doc-string-face 'font-lock-doc-string-face
"This variable should not be set.
;; If the keywords were compiled before, compile them again.
(if was-compiled
(setq font-lock-keywords
- (font-lock-compile-keywords font-lock-keywords)))))))
+ (font-lock-compile-keywords font-lock-keywords)))))))
(defun font-lock-update-removed-keyword-alist (mode keywords how)
"Update `font-lock-removed-keywords-alist' when adding new KEYWORDS to MODE."
;; If the keywords were compiled before, compile them again.
(if was-compiled
(setq font-lock-keywords
- (font-lock-compile-keywords font-lock-keywords)))))))
+ (font-lock-compile-keywords font-lock-keywords)))))))
\f
;;;;;;;;;;;;;;;;;;;;;; actual code ;;;;;;;;;;;;;;;;;;;;;;
'font-lock-after-change-function t)
(setq font-lock-defaults-computed nil
font-lock-keywords nil)
- ;; We have no business doing this here, since
+ ;; We have no business doing this here, since
;; pre-idle-hook is global. Other buffers may
;; still be in font-lock mode. -dkindred@cs.cmu.edu
;; (remove-hook 'pre-idle-hook 'font-lock-pre-idle-hook)
(or was-on (font-lock-mode 1))
(font-lock-unfontify-region (point-min) (point-max) t)
;; (buffer-syntactic-context-flush-cache)
-
+
;; If a ^G is typed during fontification, abort the fontification, but
;; return normally (do not signal.) This is to make it easy to abort
;; fontification if it's taking a long time, without also causing the
;; The following must be rethought, since keywords can override fontification.
; ;; Now scan for keywords, but not if we are inside a comment now.
; (or (and (not font-lock-keywords-only)
-; (let ((state (parse-partial-sexp beg end nil nil
+; (let ((state (parse-partial-sexp beg end nil nil
; font-lock-cache-state)))
; (or (nth 4 state) (nth 7 state))))
; (font-lock-fontify-keywords-region beg end))
(when (or (nth 3 state) (nth 4 state))
(setq string (nth 3 state) beg (point))
(setq state (parse-partial-sexp (point) end nil nil state 'syntax-table))
- (font-lock-set-face beg (point) (if string
+ (font-lock-set-face beg (point) (if string
font-lock-string-face
font-lock-comment-face)))
;;
HIGHLIGHT should be of the form MATCH-HIGHLIGHT,
see `font-lock-syntactic-keywords'."
(let* ((match (nth 0 highlight))
- (start (match-beginning match)) (end (match-end match))
- (value (nth 1 highlight))
- (override (nth 2 highlight)))
+ (start (match-beginning match)) (end (match-end match))
+ (value (nth 1 highlight))
+ (override (nth 2 highlight)))
(unless (numberp (car-safe value))
(setq value (eval value)))
(cond ((not start)
- ;; No match but we might not signal an error.
- (or (nth 3 highlight)
- (error "No match %d in highlight %S" match highlight)))
- ((not override)
- ;; Cannot override existing fontification.
- (or (map-extents 'extent-property (current-buffer)
+ ;; No match but we might not signal an error.
+ (or (nth 3 highlight)
+ (error "No match %d in highlight %S" match highlight)))
+ ((not override)
+ ;; Cannot override existing fontification.
+ (or (map-extents 'extent-property (current-buffer)
start end 'syntax-table)
(font-lock-set-syntax start end value)))
- ((eq override t)
- ;; Override existing fontification.
+ ((eq override t)
+ ;; Override existing fontification.
(font-lock-set-syntax start end value))
- ((eq override 'keep)
- ;; Keep existing fontification.
- (font-lock-fillin-text-property start end
+ ((eq override 'keep)
+ ;; Keep existing fontification.
+ (font-lock-fillin-text-property start end
'syntax-table 'font-lock value)))))
(defun font-lock-fontify-syntactic-anchored-keywords (keywords limit)
KEYWORDS should be of the form MATCH-ANCHORED, see `font-lock-keywords',
LIMIT can be modified by the value of its PRE-MATCH-FORM."
(let ((matcher (nth 0 keywords)) (lowdarks (nthcdr 3 keywords)) highlights
- ;; Evaluate PRE-MATCH-FORM.
- (pre-match-value (eval (nth 1 keywords))))
+ ;; Evaluate PRE-MATCH-FORM.
+ (pre-match-value (eval (nth 1 keywords))))
;; Set LIMIT to value of PRE-MATCH-FORM or the end of line.
(if (and (numberp pre-match-value) (> pre-match-value (point)))
- (setq limit pre-match-value)
+ (setq limit pre-match-value)
(save-excursion (end-of-line) (setq limit (point))))
(save-match-data
;; Find an occurrence of `matcher' before `limit'.
(while (if (stringp matcher)
- (re-search-forward matcher limit t)
- (funcall matcher limit))
- ;; Apply each highlight to this instance of `matcher'.
- (setq highlights lowdarks)
- (while highlights
- (font-lock-apply-syntactic-highlight (car highlights))
- (setq highlights (cdr highlights)))))
+ (re-search-forward matcher limit t)
+ (funcall matcher limit))
+ ;; Apply each highlight to this instance of `matcher'.
+ (setq highlights lowdarks)
+ (while highlights
+ (font-lock-apply-syntactic-highlight (car highlights))
+ (setq highlights (cdr highlights)))))
;; Evaluate POST-MATCH-FORM.
(eval (nth 2 keywords))))
(font-lock-compile-keywords font-lock-keywords)))
(let* ((case-fold-search font-lock-keywords-case-fold-search)
(keywords (cdr font-lock-keywords))
- (bufname (buffer-name))
+ (bufname (buffer-name))
(progress 5) (old-progress 5)
(iter 0)
(nkeywords (length keywords))
;; Fontify each item in `font-lock-keywords' from `start' to `end'.
;; In order to measure progress accurately we need to know how
;; many keywords we have and how big the region is. Then progress
- ;; is ((pos - start)/ (end - start) * nkeywords
- ;; + iteration / nkeywords) * 100
+ ;; is ((pos - start)/ (end - start) * nkeywords
+ ;; + iteration / nkeywords) * 100
(while keywords
;;
;; Find an occurrence of `matcher' from `start' to `end'.
(boundp n))
n
nil))))
- (setq font-lock-keywords
+ (setq font-lock-keywords
(symbol-value
(or (funcall try (get major-mode 'font-lock-keywords))
(funcall try (concat major "-font-lock-keywords"))
(funcall try (and (string-match "-mode\\'" major)
- (concat (substring
- major 0
+ (concat (substring
+ major 0
(match-beginning 0))
"-font-lock-keywords")))
'font-lock-keywords)))))
;; older way:
;; cleverly examine the syntax table.
(font-lock-examine-syntax-table))
-
+
;; Syntax table?
(if (nth 3 defaults)
(let ((slist (nth 3 defaults)))
;; for SYNTAX-BEGIN. Thus the calculation of the cache is usually
;; faster but not infallible, so we risk mis-fontification. --sm.
-(put 'c-mode 'font-lock-defaults
+(put 'c-mode 'font-lock-defaults
'((c-font-lock-keywords
c-font-lock-keywords-1 c-font-lock-keywords-2 c-font-lock-keywords-3)
nil nil ((?_ . "w")) beginning-of-defun))
c++-font-lock-keywords-3)
nil nil ((?_ . "w") (?~ . "w")) beginning-of-defun))
-(put 'java-mode 'font-lock-defaults
+(put 'java-mode 'font-lock-defaults
'((java-font-lock-keywords
java-font-lock-keywords-1 java-font-lock-keywords-2
java-font-lock-keywords-3)
;; belonging to it) is expected to by skip-able by `forward-sexp', and items
;; are expected to be separated with a "," or ";".
(if (looking-at (concat "[ \t*&]*"
- #r"\(\(?:\sw\|\s_\)+\)"
- #r"\(::\(\(?:\sw\|\s_\)+\)\)?"
- "[ \t]*"
- #r"\((\)?"))
+ #r"\(\(?:\sw\|\s_\)+\)"
+ #r"\(::\(\(?:\sw\|\s_\)+\)\)?"
+ "[ \t]*"
+ #r"\((\)?"))
(save-match-data
(condition-case nil
(save-restriction
;; These are all anchored at the beginning of line for speed.
;;
;; Fontify function name definitions (GNU style; without type on line).
-
+
;; In FSF this has the simpler definition of "\\sw+" for ctoken.
;; I'm not sure if ours is more correct.
;; This is a subset of the next rule, and is slower when present. --dmoore
;; x?x?x?y?z should always be: (x(xx?)?)?y?z --dmoore
(list (concat
"^\\("
- "\\(" ctoken "[ \t]+\\)" ; type specs; there can be no
+ "\\(" ctoken "[ \t]+\\)" ; type specs; there can be no
"\\("
- "\\(" ctoken "[ \t]+\\)" ; more than 3 tokens, right?
- "\\(" ctoken "[ \t]+\\)"
+ "\\(" ctoken "[ \t]+\\)" ; more than 3 tokens, right?
+ "\\(" ctoken "[ \t]+\\)"
"?\\)?\\)?"
- "\\([*&]+[ \t]*\\)?" ; pointer
- "\\(" ctoken "\\)[ \t]*(") ; name
- 10 'font-lock-function-name-face)
+ "\\([*&]+[ \t]*\\)?" ; pointer
+ "\\(" ctoken "\\)[ \t]*(") ; name
+ 10 'font-lock-function-name-face)
;;
;; This is faster but not by much. I don't see why not.
;(list (concat "^\\(" ctoken "\\)[ \t]*(") 1 'font-lock-function-name-face)
;;
;; Fontify structure names (in structure definition form).
(list (concat "^\\(typedef[ \t]+struct\\|struct\\|static[ \t]+struct\\)"
- "[ \t]+\\(" ctoken "\\)[ \t]*\\(\{\\|$\\)")
- 2 'font-lock-function-name-face)
+ "[ \t]+\\(" ctoken "\\)[ \t]*\\(\{\\|$\\)")
+ 2 'font-lock-function-name-face)
;;
;; Fontify case clauses. This is fast because its anchored on the left.
'("case[ \t]+\\(\\(\\sw\\|\\s_\\)+\\)[ \t]+:". 1)
(defvar java-font-lock-type-regexp
(concat #r"\<\(boolean\|byte\|char\|double\|float\|int"
- #r"\|long\|short\|void\)\>")
+ #r"\|long\|short\|void\)\>")
"Regexp which should match a primitive type.")
(defvar java-font-lock-identifier-regexp
(setq java-font-lock-keywords-1
(list
;; Keywords:
- (list
+ (list
(concat
#r"\<\("
#r"break\|byvalue\|"
(list (concat #r"\<\(class\|interface\)\>\s *"
java-font-lock-identifier-regexp)
2 'font-lock-function-name-face)
-
+
;; Package declarations:
(list (concat #r"\<\(package\|import\)\>\s *"
java-font-lock-identifier-regexp)
nil nil '(1 (if (equal (char-after (match-end 0)) ?.)
'font-lock-reference-face
'font-lock-type-face))))
-
+
;; Constructors:
(list (concat
"^\\s *\\(" java-modifier-regexp "\\s +\\)*"
;; Types and declared variable names:
(setq java-font-lock-keywords-2
- (append
+ (append
java-font-lock-keywords-1
(list
(goto-char (match-end 1))
(goto-char (match-end 0))
(1 font-lock-variable-name-face))))))
-
+
;; Modifier keywords and Java doc tags
(setq java-font-lock-keywords-3
(append
-
+
'(
;; Feature scoping:
;; These must come first or the Modifiers from keywords-1 will
(#r"\<protected\>" 0 font-lock-preprocessor-face)
(#r"\<public\>" 0 font-lock-reference-face))
java-font-lock-keywords-2
-
+
(list
;; Javadoc tags
'(goto-char (match-end 0)) nil
'(1 (if (equal (char-after (match-end 0)) ?.)
'font-lock-reference-face 'font-lock-type-face) t)))
-
- ;; Doc tag - Cross-references, usually to methods
+
+ ;; Doc tag - Cross-references, usually to methods
'("@see\\s +\\(\\S *[^][ \t\n\r\f(){},.;:]\\)"
1 font-lock-function-name-face t)
-
+
;; Doc tag - docRoot (1.3)
'(#r"\({ *@docRoot *}\)"
0 font-lock-keyword-face t)
;; Doc tag - Links
'(#r"{ *@link\s +\(\(\S +\)\|\(\S +\s +\S +\)\) *}"
1 font-lock-function-name-face t)
-
+
)))
)
3 (if (match-beginning 2) 'bold 'italic) keep))
"Default expressions to highlight in TeX modes.")
-(defconst ksh-font-lock-keywords
+(defconst ksh-font-lock-keywords
(list
'(#r"\(^\|[^\$\\]\)#.*" . font-lock-comment-face)
'(#r"\<\(if\|then\|else\|elif\|fi\|case\|esac\|for\|do\|done\|foreach\|in\|end\|select\|while\|repeat\|time\|function\|until\|exec\|command\|coproc\|noglob\|nohup\|nocorrect\|source\|autoload\|alias\|unalias\|export\|set\|echo\|eval\|cd\|log\|compctl\)\>" . font-lock-keyword-face)
)
"Additional expressions to highlight in ksh-mode.")
-(defconst sh-font-lock-keywords
+(defconst sh-font-lock-keywords
(list
'(#r"\(^\|[^\$\\]\)#.*" . font-lock-comment-face)
'(#r"\<\(if\|then\|else\|elif\|fi\|case\|esac\|for\|do\|done\|in\|while\|exec\|export\|set\|echo\|eval\|cd\)\>" . font-lock-keyword-face)
(function)))
(defvar font-menu-preferred-resolution
- (make-specifier-and-init 'generic '((global
+ (make-specifier-and-init 'generic '((global
((x) . "*-*"))) t)
"Preferred horizontal and vertical font menu resolution (e.g. \"75:75\").")
(from-size (aref font-data 2))
(from-weight (aref font-data 3))
(from-slant (aref font-data 4))
- (face-list-to-change (delq 'default (face-list)))
+ (face-list-to-change (delq 'default (face-list)))
new-default-face-font)
(unless from-family
(signal 'error '("couldn't parse font name for default face")))
(boundp 'x-font-regexp)
x-font-regexp)
(let
- ((- "[-?]")
+ ((- "[-?]")
(foundry "[^-]*")
- (family "[^-]*")
+ (family "[^-]*")
;(weight #r"\(bold\|demibold\|medium\|black\)")
(weight\? #r"\([^-]*\)")
;(slant #r"\([ior]\)")
that is allowable as a value for `font-lock-defaults' and will be
used to initialize the Font Lock variables."
- (with-boundp '(font-lock-auto-fontify
+ (with-boundp '(font-lock-auto-fontify
font-lock-mode-disable-list font-lock-mode-enable-list
font-lock-keywords)
(when
NAME is a symbol, which is stored in `buffer-file-format'.
DOC-STR should be a single line providing more information about the
- format. It is currently unused, but in the future will be shown to
- the user if they ask for more information.
+ format. It is currently unused, but in the future will be shown to
+ the user if they ask for more information.
REGEXP is a regular expression to match against the beginning of the file;
- it should match only files in that format.
+ it should match only files in that format.
FROM-FN is called to decode files in that format; it gets two args, BEGIN
- and END, and can make any modifications it likes, returning the new
- end. It must make sure that the beginning of the file no longer
- matches REGEXP, or else it will get called again.
+ and END, and can make any modifications it likes, returning the new
+ end. It must make sure that the beginning of the file no longer
+ matches REGEXP, or else it will get called again.
Alternatively, FROM-FN can be a string, which specifies a shell command
(including options) to be used as a filter to perform the conversion.
TO-FN is called to encode a region into that format; it is passed three
- arguments: BEGIN, END, and BUFFER. BUFFER is the original buffer that
- the data being written came from, which the function could use, for
- example, to find the values of local variables. TO-FN should either
- return a list of annotations like `write-region-annotate-functions',
- or modify the region and return the new end.
+ arguments: BEGIN, END, and BUFFER. BUFFER is the original buffer that
+ the data being written came from, which the function could use, for
+ example, to find the values of local variables. TO-FN should either
+ return a list of annotations like `write-region-annotate-functions',
+ or modify the region and return the new end.
Alternatively, TO-FN can be a string, which specifies a shell command
(including options) to be used as a filter to perform the conversion.
MODIFY, if non-nil, means the TO-FN wants to modify the region. If nil,
- TO-FN will not make any changes but will instead return a list of
- annotations.
+ TO-FN will not make any changes but will instead return a list of
+ annotations.
MODE-FN, if specified, is called when visiting a file with that format.")
(let ((old-frame (gensym "ssf")))
`(let ((,old-frame (selected-frame)))
(unwind-protect
- (progn ,@body)
- (select-frame ,old-frame)))))
+ (progn ,@body)
+ (select-frame ,old-frame)))))
(defmacro with-selected-frame (frame &rest body)
"Execute forms in BODY with FRAME as the selected frame.
:group 'frames)
(defcustom get-frame-for-buffer-default-instance-limit nil
- "*The default instance limit for creating new frames;
+ "*The default instance limit for creating new frames;
see doc of `get-frame-for-buffer'."
:type 'integer
:group 'frames)
;; Sort the list so that iconic frames will be found last. They
;; will be used too, but mapped frames take precedence. And
;; fully visible frames come before occluded frames.
- ;; Hidden frames come after really visible ones
+ ;; Hidden frames come after really visible ones
(setq frames
(sort (frame-list)
#'(lambda (s1 s2)
;; finish initializing sxemacs logo -- created internally because it
;; has a built-in bitmap
(let ((temp-etcdir
- (if (getenv "SOURCE_TREE_ROOT")
- (expand-file-name "etc/" (getenv "SOURCE_TREE_ROOT"))
- (expand-file-name "etc/" ".."))))
+ (if (getenv "SOURCE_TREE_ROOT")
+ (expand-file-name "etc/" (getenv "SOURCE_TREE_ROOT"))
+ (expand-file-name "etc/" ".."))))
(when debug-paths
(princ (format "tempetc: %s\n" temp-etcdir)
- 'external-debugging-output))
+ 'external-debugging-output))
(if (featurep 'xpm)
- (set-glyph-image sxemacs-logo
- (expand-file-name
- (if emacs-beta-version
- "sxemacs-beta.xpm"
- "sxemacs.xpm") temp-etcdir)
- 'global 'x))
+ (set-glyph-image sxemacs-logo
+ (expand-file-name
+ (if emacs-beta-version
+ "sxemacs-beta.xpm"
+ "sxemacs.xpm") temp-etcdir)
+ 'global 'x))
(cond ((featurep 'xpm)
- (set-glyph-image frame-icon-glyph
- (expand-file-name "sxemacs-icon.xpm" temp-etcdir)
- 'global 'x))
- ((featurep 'x)
- (set-glyph-image frame-icon-glyph
- (expand-file-name "xemacs-icon2.xbm" temp-etcdir)
- 'global 'x)))
+ (set-glyph-image frame-icon-glyph
+ (expand-file-name "sxemacs-icon.xpm" temp-etcdir)
+ 'global 'x))
+ ((featurep 'x)
+ (set-glyph-image frame-icon-glyph
+ (expand-file-name "xemacs-icon2.xbm" temp-etcdir)
+ 'global 'x)))
(if (featurep 'tty)
- (set-glyph-image sxemacs-logo
- "SXEmacs <insert spiffy graphic logo here>"
- 'global 'tty))))
+ (set-glyph-image sxemacs-logo
+ "SXEmacs <insert spiffy graphic logo here>"
+ 'global 'tty))))
(init-glyphs)
:tag "Gnuserv Frame"
:type '(radio (const :tag "Create new frame each time" nil)
(const :tag "Use selected frame" t)
- (function-item :tag "Use main Emacs frame"
+ (function-item :tag "Use main Emacs frame"
gnuserv-main-frame-function)
(function-item :tag "Use visible frame, otherwise create new"
gnuserv-visible-frame-function)
ID - Client id (integer).
BUFFERS - List of buffers that \"belong\" to the client.
- NOTE: one buffer can belong to several clients.
+ NOTE: one buffer can belong to several clients.
DEVICE - The device this client is on. If the device was also created.
- by a client, it will be placed to `gnuserv-devices' list.
+ by a client, it will be placed to `gnuserv-devices' list.
FRAME - Frame created by the client, or nil if the client didn't
- create a frame.
+ create a frame.
All the slots default to nil."
(id nil)
;; Maintainer: SXEmacs Development Team
;; Keywords: internal, dumped
-
+
;; This file is part of SXEmacs.
;; SXEmacs is free software: you can redistribute it and/or modify
(defcustom gutter-buffers-tab-visible-p
(gutter-element-visible-p default-gutter-visible-p 'buffers-tab)
- "Whether the buffers tab is globally visible.
+ "Whether the buffers tab is globally visible.
There are side-effects, so don't setq it; use Customize or the options menu."
:group 'buffers-tab
:type 'boolean
:set #'(lambda (var val)
- (set-gutter-element-visible-p default-gutter-visible-p
+ (set-gutter-element-visible-p default-gutter-visible-p
'buffers-tab val)
(setq gutter-buffers-tab-visible-p val)))
:type 'face
:group 'buffers-tab)
-(defcustom buffers-tab-grouping-regexp
+(defcustom buffers-tab-grouping-regexp
'(#r"^\(gnus-\|message-mode\|mime/viewer-mode\)"
#r"^\(emacs-lisp-\|lisp-\)")
"*If non-nil, a list of regular expressions for buffer grouping.
"*Maximum length of text which may appear in a \"Buffers\" tab.
This is a specifier, use set-specifier to modify it.")
-(defcustom buffers-tab-max-buffer-line-length
+(defcustom buffers-tab-max-buffer-line-length
(specifier-instance buffers-tab-default-buffer-line-length)
"*Maximum length of text which may appear in a \"Buffers\" tab.
Buffer names over this length will be truncated with elipses.
"For use as a value of `buffers-tab-selection-function'.
This selects buffers by major mode `buffers-tab-grouping-regexp'."
(let ((mode1 (symbol-name (symbol-value-in-buffer 'major-mode buf1)))
- (mode2 (symbol-name (symbol-value-in-buffer 'major-mode
+ (mode2 (symbol-name (symbol-value-in-buffer 'major-mode
buffer-to-select)))
(modenm1 (symbol-value-in-buffer 'mode-name buf1))
(modenm2 (symbol-value-in-buffer 'mode-name buffer-to-select)))
(eq modenm1 modenm2)
(and (string-match "^[^-]+-" mode1)
(string-match
- (concat "^" (regexp-quote
+ (concat "^" (regexp-quote
(substring mode1 0 (match-end 0))))
mode2))
(and buffers-tab-grouping-regexp
(if (and (> len 0)
(> (length (buffer-name buffer)) len))
(if (string-match ".*<.>$" (buffer-name buffer))
- (concat (substring (buffer-name buffer)
+ (concat (substring (buffer-name buffer)
0 (- len 6)) "..."
(substring (buffer-name buffer) -3))
(concat (substring (buffer-name buffer)
(mapcar
#'(lambda (buffer)
(prog1
- (vector
+ (vector
(funcall buffers-tab-format-buffer-line-function
buffer)
(list buffers-tab-switch-to-buffer-function
;; NB it is too late if we run the omit function as part of the
;; filter functions because we need to know which buffer is the
;; context buffer before they get run.
- (let* ((buffers (delete-if
+ (let* ((buffers (delete-if
buffers-tab-omit-function (buffer-list frame)))
(first-buf (car buffers)))
;; maybe force the selected window
(setq buffers (cons (window-buffer (selected-window frame))
(delq first-buf buffers))))
;; if we're in deletion ignore the current buffer
- (when in-deletion
+ (when in-deletion
(setq buffers (delq (current-buffer) buffers))
(setq first-buf (car buffers)))
;; filter buffers
(when buffers-tab-filter-functions
(setq buffers
- (delete-if
- #'null
+ (delete-if
+ #'null
(mapcar #'(lambda (buf)
(let ((tmp-buf buf))
(mapc #'(lambda (fun)
(let* ((gutter-string (copy-sequence "\n"))
(gutter-buffers-tab-extent (make-extent 0 1 gutter-string)))
(set-extent-begin-glyph gutter-buffers-tab-extent
- (setq gutter-buffers-tab
+ (setq gutter-buffers-tab
(make-glyph)))
;; Nuke all existing tabs
(remove-gutter-element top-gutter 'buffers-tab)
(cond ((eq gutter-buffers-tab-orientation 'top)
;; This looks better than a 3d border
(set-specifier top-gutter-border-width 0 'global x)
- (set-gutter-element top-gutter 'buffers-tab
+ (set-gutter-element top-gutter 'buffers-tab
gutter-string 'global x))
((eq gutter-buffers-tab-orientation 'bottom)
(set-specifier bottom-gutter-border-width 0 'global x)
:pixel-width :pixel-height)
(if (or (eq gutter-buffers-tab-orientation 'top)
(eq gutter-buffers-tab-orientation 'bottom))
- '(gutter-pixel-width) '(gutter-pixel-height))
+ '(gutter-pixel-width) '(gutter-pixel-height))
:items items)
frame)
;; set-glyph-image will not make the gutter dirty
(set-gutter-dirty-p gutter-buffers-tab-orientation)))))))
;; A myriad of different update hooks all doing slightly different things
-(add-one-shot-hook
+(add-one-shot-hook
'after-init-hook
#'(lambda ()
;; don't add the hooks if the user really doesn't want them
(when gutter-buffers-tab-enabled
- (add-hook 'create-frame-hook
+ (add-hook 'create-frame-hook
#'(lambda (frame)
(when gutter-buffers-tab (update-tab-in-gutter frame t))))
(add-hook 'buffer-list-changed-hook 'update-tab-in-gutter)
,progress-text-instantiator)])
(set-glyph-image progress-layout-glyph progress-layout-instantiator
locale))
- (t
+ (t
(setq progress-glyph-height 24)
(setq progress-layout-instantiator
- `[layout
+ `[layout
:orientation vertical :margin-width 4
:horizontally-justify left :vertically-justify center
:items (,progress-text-instantiator
- [layout
+ [layout
:orientation horizontal
:items (,progress-gauge-instantiator
- [button
+ [button
:pixel-height (eval progress-glyph-height)
:descriptor " Stop "
;; 'quit is special and acts "asynchronously".
oldmsg)
;; nothing to display so get rid of the gauge
(set-specifier bottom-gutter-border-width 0 frame)
- (set-gutter-element-visible-p bottom-gutter-visible-p
+ (set-gutter-element-visible-p bottom-gutter-visible-p
'progress nil frame)))))
(defun progress-feedback-clear-when-idle (&optional label)
(defun progress-feedback-dispatch-non-command-events ()
;; don't allow errors to hose things
- (condition-case t
+ (condition-case t
;; (sit-for 0) is too agressive and cause more display than we
;; want.
(dispatch-non-command-events)
(progn
(setcdr top message)
(if (equal tmsg message)
- (progn
+ (progn
(set-instantiator-property progress-gauge-instantiator :value value)
(set-progress-feedback-instantiator (frame-selected-window frame)))
(raw-append-progress-feedback message value frame))
(set-instantiator-property progress-text-instantiator :data message)
(set-progress-abort-instantiator (frame-selected-window frame))
(set-specifier bottom-gutter-height 'autodetect frame)
- (set-gutter-element-visible-p bottom-gutter-visible-p
+ (set-gutter-element-visible-p bottom-gutter-visible-p
'progress t frame)
;; we have to do this so redisplay is up-to-date and so
;; redisplay-gutter-area performs optimally.
(abort-progress-feedback label message frame))
((or (not (valid-image-instantiator-format-p 'progress-gauge frame))
progress-feedback-use-echo-area)
- (display-message label
+ (display-message label
(concat message (if (eq value 100) "done."
(make-string (/ value 5) ?.)))
frame))
"Remove gutter element PROP from GUTTER-SPECIFIER in optional LOCALE.
This is a convenience function for removing gutter elements."
(modify-specifier-instances gutter-specifier #'plist-remprop (list prop)
- 'force nil locale tag-set))
+ 'force nil locale tag-set))
(defun set-gutter-element-visible-p (gutter-visible-specifier-p
prop &optional visible-p
non-nil if it is visible in optional DOMAIN."
(let ((spec (specifier-instance gutter-visible-specifier-p domain)))
(or (and (listp spec) (memq 'buffers-tab spec))
- spec)))
+ spec)))
(defun set-gutter-dirty-p (gutter-or-location)
"Make GUTTER-OR-LOCATION dirty to force redisplay updates."
(eq gutter-or-location 'bottom)
(eq gutter-or-location 'left)
(eq gutter-or-location 'right))
- (or (gutter-specifier-p gutter-or-location)
+ (or (gutter-specifier-p gutter-or-location)
(setq gutter-or-location
- (eval (intern (concat
+ (eval (intern (concat
(symbol-name gutter-or-location)
"-gutter")))))
(set-specifier-dirty-flag gutter-or-location)))
)
;;; gutter.el ends here.
-
-
;;->
;;->c Redistribute civs from overfull sectors into connected underfull ones
;;-> The functions typically named by empire-ideal-civ-fcn control
-;;-> based in part on empire-sector-civ-threshold
+;;-> based in part on empire-sector-civ-threshold
;;->m Redistribute military using levels given by empire-ideal-mil-fcn
;;->p Redistribute excess population to highways for max pop growth
;;-> Excess is any sector so full babies will not be born.
(set-window-configuration config))))))))
;;; help-macro.el
-
(globally-declare-fboundp
'(find-function find-variable view-scroll-lines-up)))
-(require 'loadhist) ;; For symbol-file.
+(require 'loadhist) ;; For symbol-file.
(defgroup help nil
"Support for on-line help systems."
:group 'help)
(defvar help-map (let ((map (make-sparse-keymap)))
- (set-keymap-name map 'help-map)
- (set-keymap-prompt
+ (set-keymap-name map 'help-map)
+ (set-keymap-prompt
map (gettext "(Type ? for further options)"))
- map)
+ map)
"Keymap for characters following the Help key.")
;; global-map definitions moved to keydefs.el
defn menup)
(setq defn (key-or-menu-binding key 'menup))
(if (or (null defn) (integerp defn))
- (princ (format "%s is undefined" (key-description key)))
+ (princ (format "%s is undefined" (key-description key)))
;; If it's a keyboard macro which trivially invokes another command,
;; document that instead.
(if (or (stringp defn) (vectorp defn))
(funcall
(or function 'message)
(concat
- (substitute-command-keys
- (if (one-window-p t)
- (if pop-up-windows
- (gettext "Type \\[delete-other-windows] to remove help window.")
- (gettext "Type \\[switch-to-buffer] RET to remove help window."))
+ (substitute-command-keys
+ (if (one-window-p t)
+ (if pop-up-windows
+ (gettext "Type \\[delete-other-windows] to remove help window.")
+ (gettext "Type \\[switch-to-buffer] RET to remove help window."))
(gettext "Type \\[switch-to-buffer-other-window] RET to restore the other window.")))
- (substitute-command-keys
- (gettext " \\[scroll-other-window] to scroll the help."))))))
+ (substitute-command-keys
+ (gettext " \\[scroll-other-window] to scroll the help."))))))
(defcustom help-selects-help-window t
"*If nil, use the \"old Emacs\" behavior for Help buffers.
(setq help-buffer-list (remove newbuf help-buffer-list))
;; maybe kill excess help buffers
(if (and (integerp help-max-help-buffers)
- (> (length help-buffer-list) help-max-help-buffers))
+ (> (length help-buffer-list) help-max-help-buffers))
(let ((keep-list nil)
- (num-kill (- (length help-buffer-list)
- help-max-help-buffers)))
- (while help-buffer-list
- (let ((buf (car help-buffer-list)))
- (if (and (or (equal buf newbuf) (get-buffer buf))
- (string-match "^*Help" buf)
- (save-excursion (set-buffer buf)
- (eq major-mode 'help-mode)))
- (if (and (>= num-kill (length help-buffer-list))
- (not (get-buffer-window buf t t)))
- (kill-buffer buf)
- (setq keep-list (cons buf keep-list)))))
- (setq help-buffer-list (cdr help-buffer-list)))
- (setq help-buffer-list (nreverse keep-list))))
+ (num-kill (- (length help-buffer-list)
+ help-max-help-buffers)))
+ (while help-buffer-list
+ (let ((buf (car help-buffer-list)))
+ (if (and (or (equal buf newbuf) (get-buffer buf))
+ (string-match "^*Help" buf)
+ (save-excursion (set-buffer buf)
+ (eq major-mode 'help-mode)))
+ (if (and (>= num-kill (length help-buffer-list))
+ (not (get-buffer-window buf t t)))
+ (kill-buffer buf)
+ (setq keep-list (cons buf keep-list)))))
+ (setq help-buffer-list (cdr help-buffer-list)))
+ (setq help-buffer-list (nreverse keep-list))))
;; push new buffer
(setq help-buffer-list (cons newbuf help-buffer-list)))
(defun help-buffer-name (name)
"Return a name for a Help buffer using string NAME for context."
(if (and (integerp help-max-help-buffers)
- (> help-max-help-buffers 0)
- (stringp name))
+ (> help-max-help-buffers 0)
+ (stringp name))
(if help-buffer-prefix-string
(format "*%s: %s*" help-buffer-prefix-string name)
(format "*%s*" name))
(let ((defn (key-or-menu-binding key))
(key-string (key-description key)))
(if (or (null defn) (integerp defn))
- (message "%s is undefined" key-string)
+ (message "%s is undefined" key-string)
(with-displaying-help-buffer
(lambda ()
(princ key-string)
(defun describe-bindings-1 (&optional prefix mouse-only-p)
(let ((heading (if mouse-only-p
- (gettext "button binding\n------ -------\n")
- (gettext "key binding\n--- -------\n")))
- (buffer (current-buffer))
- (minor minor-mode-map-alist)
+ (gettext "button binding\n------ -------\n")
+ (gettext "key binding\n--- -------\n")))
+ (buffer (current-buffer))
+ (minor minor-mode-map-alist)
(extent-maps (mapcar-extents
'extent-keymap
nil (current-buffer) (point) (point) nil 'keymap))
- (local (current-local-map))
- (shadow '()))
+ (local (current-local-map))
+ (shadow '()))
(set-buffer standard-output)
(while extent-maps
(insert "Bindings for Text Region:\n"
extent-maps (cdr extent-maps)))
(while minor
(let ((sym (car (car minor)))
- (map (cdr (car minor))))
- (if (symbol-value-in-buffer sym buffer nil)
- (progn
- (insert (format "Minor Mode Bindings for `%s':\n"
- sym)
- heading)
- (describe-bindings-internal map nil shadow prefix mouse-only-p)
- (insert "\n")
- (setq shadow (cons map shadow))))
- (setq minor (cdr minor))))
+ (map (cdr (car minor))))
+ (if (symbol-value-in-buffer sym buffer nil)
+ (progn
+ (insert (format "Minor Mode Bindings for `%s':\n"
+ sym)
+ heading)
+ (describe-bindings-internal map nil shadow prefix mouse-only-p)
+ (insert "\n")
+ (setq shadow (cons map shadow))))
+ (setq minor (cdr minor))))
(if local
- (progn
- (insert "Local Bindings:\n" heading)
- (describe-bindings-internal local nil shadow prefix mouse-only-p)
- (insert "\n")
- (setq shadow (cons local shadow))))
+ (progn
+ (insert "Local Bindings:\n" heading)
+ (describe-bindings-internal local nil shadow prefix mouse-only-p)
+ (insert "\n")
+ (setq shadow (cons local shadow))))
(insert "Global Bindings:\n" heading)
(describe-bindings-internal (current-global-map)
- nil shadow prefix mouse-only-p)
+ nil shadow prefix mouse-only-p)
(when (and prefix function-key-map (not mouse-only-p))
(insert "\nFunction key map translations:\n" heading)
(describe-bindings-internal function-key-map nil nil
\(Use SPC or DEL to scroll through this text. Type \\<help-map>\\[help-quit] to exit the Help command.)
\\[hyper-apropos] Type a substring; it shows a hypertext list of
- functions and variables that contain that substring.
+ functions and variables that contain that substring.
See also the `apropos' command.
\\[command-apropos] Type a substring; it shows a list of commands
- (interactively callable functions) that contain that substring.
+ (interactively callable functions) that contain that substring.
\\[describe-bindings] Table of all key bindings.
\\[describe-key-briefly] Type a command key sequence;
- it displays the function name that sequence runs.
+ it displays the function name that sequence runs.
\\[customize] Customize Emacs options.
\\[Info-goto-emacs-command-node] Type a function name; it displays the Info node for that command.
\\[describe-function] Type a function name; it shows its documentation.
\\[info] Info documentation reader.
\\[Info-query] Type an Info file name; it displays it in Info reader.
\\[describe-key] Type a command key sequence;
- it displays the documentation for the command bound to that key.
+ it displays the documentation for the command bound to that key.
\\[Info-goto-emacs-key-command-node] Type a command key sequence;
- it displays the Info node for the command bound to that key.
+ it displays the Info node for the command bound to that key.
\\[view-lossage] Recent input keystrokes and minibuffer messages.
\\[describe-mode] Documentation of current major and minor modes.
\\[view-emacs-news] News of recent SXEmacs changes.
`function-at-point'."
(interactive
(let* ((fn (function-at-point))
- (val (let ((enable-recursive-minibuffers t))
- (completing-read
- (if fn
- (format (gettext "Describe function (default %s): ")
+ (val (let ((enable-recursive-minibuffers t))
+ (completing-read
+ (if fn
+ (format (gettext "Describe function (default %s): ")
fn)
- (gettext "Describe function: "))
- obarray 'fboundp t nil 'function-history
+ (gettext "Describe function: "))
+ obarray 'fboundp t nil 'function-history
(symbol-name fn)))))
(list (intern val))))
(with-displaying-help-buffer
((equal args "") nil)
(args))))
(t t)))
- (print-gensym nil))
+ (print-gensym nil))
(cond ((listp arglist)
(prin1-to-string
(cons function (loop
- for arg in arglist
- collect (if (memq arg '(&optional &rest))
- arg
- (make-symbol (upcase (symbol-name
- arg))))))
+ for arg in arglist
+ collect (if (memq arg '(&optional &rest))
+ arg
+ (make-symbol (upcase (symbol-name
+ arg))))))
t))
((stringp arglist)
(format "(%s %s)" function arglist)))))
(void-function "(alias for undefined function)")
(error "(unexpected error from `documention')"))))
(when (and strip-arglist
- (string-match "[\n\t ]*\narguments: ?(\\([^)]*\\))\n?\\'" doc))
+ (string-match "[\n\t ]*\narguments: ?(\\([^)]*\\))\n?\\'" doc))
(setq doc (substring doc 0 (match-beginning 0)))
(and (zerop (length doc)) (setq doc (gettext "not documented"))))
doc))
(an-p "an ")
(t "a "))
"%s"
- (cond
- ((eq 'neither macro-p)
- "")
- (macro-p " macro")
- (t " function"))))
+ (cond
+ ((eq 'neither macro-p)
+ "")
+ (macro-p " macro")
+ (t " function"))))
string)))))
(cond ((or (stringp def) (vectorp def))
- (princ "a keyboard macro.")
+ (princ "a keyboard macro.")
(setq kbd-macro-p t))
- ((special-form-p fndef)
- (funcall int "built-in special form" nil 'neither))
- ((subrp fndef)
- (funcall int "built-in" nil macrop))
- ((compiled-function-p fndef)
- (funcall int "compiled Lisp" nil macrop))
- ((eq (car-safe fndef) 'lambda)
- (funcall int "Lisp" nil macrop))
- ((eq (car-safe def) 'autoload)
+ ((special-form-p fndef)
+ (funcall int "built-in special form" nil 'neither))
+ ((subrp fndef)
+ (funcall int "built-in" nil macrop))
+ ((compiled-function-p fndef)
+ (funcall int "compiled Lisp" nil macrop))
+ ((eq (car-safe fndef) 'lambda)
+ (funcall int "Lisp" nil macrop))
+ ((eq (car-safe def) 'autoload)
(funcall int "autoloaded Lisp" t (elt def 4)))
((and (symbolp def) (not (fboundp def)))
(princ "a symbol with a void (unbound) function definition."))
- (t
- nil)))
+ (t
+ nil)))
(princ "\n")
(or file-name
(setq file-name (symbol-file function 'defun)))
(princ file-name)
(let ((opoint (point standard-output))
e)
- (require 'hyper-apropos)
+ (require 'hyper-apropos)
(princ file-name)
(setq e (make-extent opoint (point standard-output)
standard-output))
(princ "\nInvoked with:\n")
(let ((global-binding
(where-is-internal function global-map))
- (global-tty-binding
+ (global-tty-binding
(where-is-internal function global-tty-map))
- (global-window-system-binding
+ (global-window-system-binding
(where-is-internal function global-window-system-map)))
- (if (or global-binding global-tty-binding
- global-window-system-binding)
- (if (and (equal global-binding
- global-tty-binding)
- (equal global-binding
- global-window-system-binding))
- (princ
- (substitute-command-keys
- (format "\n\\[%s]" function)))
- (when (and global-window-system-binding
- (not (equal global-window-system-binding
- global-binding)))
- (princ
- (format
- "\n%s\n -- under window systems\n"
- (mapconcat #'key-description
- global-window-system-binding
- ", "))))
- (when (and global-tty-binding
- (not (equal global-tty-binding
- global-binding)))
- (princ
- (format
- "\n%s\n -- under TTYs\n"
- (mapconcat #'key-description
- global-tty-binding
- ", "))))
- (when global-binding
- (princ
- (format
- "\n%s\n -- generally (that is, unless\
+ (if (or global-binding global-tty-binding
+ global-window-system-binding)
+ (if (and (equal global-binding
+ global-tty-binding)
+ (equal global-binding
+ global-window-system-binding))
+ (princ
+ (substitute-command-keys
+ (format "\n\\[%s]" function)))
+ (when (and global-window-system-binding
+ (not (equal global-window-system-binding
+ global-binding)))
+ (princ
+ (format
+ "\n%s\n -- under window systems\n"
+ (mapconcat #'key-description
+ global-window-system-binding
+ ", "))))
+ (when (and global-tty-binding
+ (not (equal global-tty-binding
+ global-binding)))
+ (princ
+ (format
+ "\n%s\n -- under TTYs\n"
+ (mapconcat #'key-description
+ global-tty-binding
+ ", "))))
+ (when global-binding
+ (princ
+ (format
+ "\n%s\n -- generally (that is, unless\
overridden by TTY- or
- window-system-specific mappings)\n"
- (mapconcat #'key-description
- global-binding
- ", ")))))
- (princ (substitute-command-keys
- (format "\n\\[%s]" function))))))))))))
+ window-system-specific mappings)\n"
+ (mapconcat #'key-description
+ global-binding
+ ", ")))))
+ (princ (substitute-command-keys
+ (format "\n\\[%s]" function))))))))))))
"Display the full documentation of VARIABLE (a symbol)."
(interactive
(let* ((v (variable-at-point))
- (val (let ((enable-recursive-minibuffers t))
- (completing-read
- (if v
- (format "Describe variable (default %s): " v)
- (gettext "Describe variable: "))
- obarray 'boundp t nil 'variable-history
+ (val (let ((enable-recursive-minibuffers t))
+ (completing-read
+ (if v
+ (format "Describe variable (default %s): " v)
+ (gettext "Describe variable: "))
+ obarray 'boundp t nil 'variable-history
(symbol-name v)))))
(list (intern val))))
(with-displaying-help-buffer
(set-extent-property e 'find-variable-symbol variable))
(princ"\"\n")))
(princ "\nValue: ")
- (if (not (boundp variable))
+ (if (not (boundp variable))
(Help-princ-face "void\n" 'hyper-apropos-documentation)
(Help-prin1-face (symbol-value variable)
'hyper-apropos-documentation)
(setq val (read-command
(if fn (format "Where is command (default %s): " fn)
"Where is command: ")
- (and fn (symbol-name fn))))
+ (and fn (symbol-name fn))))
(list (if (equal (symbol-name val) "")
fn val)
current-prefix-arg)))
(if e
(find-function (extent-property e 'find-function-symbol))
(setq e (extent-at pos nil 'find-variable-symbol))
- (if e
+ (if e
(find-variable (extent-property e 'find-variable-symbol))
(view-scroll-lines-up 1)))))
(defun help-mouse-find-source-or-track (event)
- "Follow any cross reference to source code under the mouse;
+ "Follow any cross reference to source code under the mouse;
if none, call mouse-track. "
(interactive "e")
(mouse-set-point event)
(if e
(find-function (extent-property e 'find-function-symbol))
(setq e (extent-at (point) nil 'find-variable-symbol))
- (if e
+ (if e
(find-variable (extent-property e 'find-variable-symbol))
(view-scroll-lines-up 1)))))
(defun hyper-apropos-mode (regexp)
"Improved apropos mode for displaying Emacs documentation. Function and
-variable names are displayed in the buffer \"*Hyper Apropos*\".
+variable names are displayed in the buffer \"*Hyper Apropos*\".
Functions are preceded by a single character to indicates their types:
a = autoloaded, b = byte-compiled, i = internal, l = lambda, m = macro.
General Commands:
- SPC - scroll documentation or apropos window forward
- b - scroll documentation or apropos window backward
+ SPC - scroll documentation or apropos window forward
+ b - scroll documentation or apropos window backward
k - eliminate all hits that don't contain keyword
n - new search
- / - isearch-forward
- q - quit and restore previous window configuration
-
+ / - isearch-forward
+ q - quit and restore previous window configuration
+
Operations for Symbol on Current Line:
-
- RET - toggle display of symbol's documentation
+
+ RET - toggle display of symbol's documentation
(also on button2 in xemacs)
- w - show the keybinding if symbol is a command
- i - invoke function on current line
- s - set value of variable on current line
+ w - show the keybinding if symbol is a command
+ i - invoke function on current line
+ s - set value of variable on current line
t - display the C or lisp source (find-tag)"
(delete-other-windows)
(setq mode-name "Hyper-Apropos"
(defun hyper-describe-key-briefly (key &optional show)
(interactive "kDescribe key briefly: \nP")
(let (menup defn interm final msg)
- (setq defn (key-or-menu-binding key 'menup))
+ (setq defn (key-or-menu-binding key 'menup))
(if (or (null defn) (integerp defn))
- (or (numberp show) (message "%s is undefined" (key-description key)))
+ (or (numberp show) (message "%s is undefined" (key-description key)))
(cond ((stringp defn)
(setq interm defn
final (key-binding defn)))
(setq interm (butlast interm)))
(if final
(setq interm (vconcat interm))
- (setq interm defn
+ (setq interm defn
final (key-binding defn)))))
(setq msg (format
"%s runs %s%s%s"
(or (find-face v)
(setq v (variable-at-point)))
(setq val (let ((enable-recursive-minibuffers t))
- (completing-read
+ (completing-read
(concat (if (hyper-apropos-follow-ref-buffer current-prefix-arg)
"Follow face"
"Describe face")
"see below")
"is void")))
-(defun hyper-apropos-follow-ref-buffer (this-ref-buffer)
+(defun hyper-apropos-follow-ref-buffer (this-ref-buffer)
(and (not this-ref-buffer)
(eq major-mode 'hyper-apropos-help-mode)
hyper-apropos-ref-buffer
"()")))
((and (or (eq symtype 'subr) (eq symtype 'autoload))
(string-match
- "[\n\t ]*\narguments: ?(\\([^)]*\\))\n?\\'"
- doc))
+ "[\n\t ]*\narguments: ?(\\([^)]*\\))\n?\\'"
+ doc))
(insert (substring doc
(match-beginning 1)
(match-end 1)))
;; variable ----------------------------------------------------------
(and (memq 'variable type)
(or (boundp symbol) (default-boundp symbol))
- (progn
+ (progn
(setq ok t)
(setq aliases (hyper-apropos-get-alias symbol
'variable-alias
(setq symtype (cdr symtype)))))))
(save-excursion
(set-buffer hyper-apropos-help-buf)
- (goto-char (point-min))
+ (goto-char (point-min))
;; pop up window and shrink it if it's wasting space
(if hyper-apropos-shrink-window
(shrink-window-if-larger-than-buffer
(let ((regexp (regexp-quote fill-prefix)))
(while (< (point) end)
(or (looking-at regexp)
- (and (bolp) (eolp))
+ (and (bolp) (eolp))
(insert fill-prefix))
(forward-line 1))))
(if indent-region-function
(goto-char start)
(or (bolp) (forward-line 1))
(while (< (point) end)
- (or (and (bolp) (eolp))
- (funcall indent-line-function))
+ (or (and (bolp) (eolp))
+ (funcall indent-line-function))
(forward-line 1))
(move-marker end nil))))
(setq column (prefix-numeric-value column))
(goto-char start)
(while (re-search-forward
(concat #r"^\* \([^:]+\):\("
- "[ \t]*"
- #r"(\([^)]*\))\w*\.\|:\)")
- nil t)
+ "[ \t]*"
+ #r"(\([^)]*\))\w*\.\|:\)")
+ nil t)
(setq entry (list (match-string 2)
(match-string 1)
(downcase (or (match-string 3)
nil t))
(let (filename)
(string-match (concat #r"\s *\((\s *\("
- "[^\t)]*"
- #r"\)\s *)\s *\|\)\(.*\)")
+ "[^\t)]*"
+ #r"\)\s *)\s *\|\)\(.*\)")
nodename)
(setq filename (if (= (match-beginning 1) (match-end 1))
""
(setq Info-last-search regexp)
(with-search-caps-disable-folding regexp t
(let ((found ())
- (onode Info-current-node)
- (ofile Info-current-file)
- (opoint (point))
- (osubfile Info-current-subfile))
+ (onode Info-current-node)
+ (ofile Info-current-file)
+ (opoint (point))
+ (osubfile Info-current-subfile))
(save-excursion
- (save-restriction
- (widen)
- (if (null Info-current-subfile)
- (progn (re-search-forward regexp) (setq found (point)))
- (condition-case nil
- (progn (re-search-forward regexp) (setq found (point)))
- (search-failed nil)))))
+ (save-restriction
+ (widen)
+ (if (null Info-current-subfile)
+ (progn (re-search-forward regexp) (setq found (point)))
+ (condition-case nil
+ (progn (re-search-forward regexp) (setq found (point)))
+ (search-failed nil)))))
(if (not found)
;; can only happen in subfile case -- else would have erred
- (unwind-protect
- (let ((list ()))
- (save-excursion
+ (unwind-protect
+ (let ((list ()))
+ (save-excursion
(set-buffer (marker-buffer Info-tag-table-marker))
(goto-char (point-min))
(search-forward "\n\^_\nIndirect:")
(goto-char (1+ (match-end 0))))
(setq list (nreverse list)
list (cdr list))))
- (while list
- (message "Searching subfile %s..." (cdr (car list)))
- (Info-read-subfile (car (car list)))
- (setq list (cdr list))
- (goto-char (point-min))
- (if (re-search-forward regexp nil t)
- (setq found (point) list ())))
- (if found
- (message "")
- (signal 'search-failed (list regexp))))
- (if (not found)
- (progn (Info-read-subfile opoint)
- (goto-char opoint)
- (Info-select-node)))))
+ (while list
+ (message "Searching subfile %s..." (cdr (car list)))
+ (Info-read-subfile (car (car list)))
+ (setq list (cdr list))
+ (goto-char (point-min))
+ (if (re-search-forward regexp nil t)
+ (setq found (point) list ())))
+ (if found
+ (message "")
+ (signal 'search-failed (list regexp))))
+ (if (not found)
+ (progn (Info-read-subfile opoint)
+ (goto-char opoint)
+ (Info-select-node)))))
(widen)
(goto-char found)
(Info-select-node)
(or (and (equal onode Info-current-node)
- (equal ofile Info-current-file))
- (Info-history-add ofile onode opoint)))))
+ (equal ofile Info-current-file))
+ (Info-history-add ofile onode opoint)))))
\f
;; Extract the value of the node-pointer named NAME.
;; If there is none, use ERRORNAME in the error message;
(defun Info-next-reference (n)
(interactive "p")
(let ((pat (format (concat "\\*%s[ \n\t]*"
- #r"\([^:]*\):\|^\* .*:\|<<.*>>")
+ #r"\([^:]*\):\|^\* .*:\|<<.*>>")
Info-footnote-tag))
(old-pt (point))
wrapped found-nomenu)
(if (string= item "")
(if default
(setq item default)
- ;; ask again
- (setq item nil))))
+ ;; ask again
+ (setq item nil))))
(list item))))
;; there is a problem here in that if several menu items have the same
;; name you can only go to the node of the first with this command.
(format " (default %s)" fn)
""))
obarray 'fboundp t
- nil nil (and fn (symbol-name fn))))
+ nil nil (and fn (symbol-name fn))))
(list (if (equal val "")
fn (intern val)))))
(save-window-excursion
;; #### What we really need is a buffer-local
;; overriding-local-map. See isearch-pre-command-hook for
;; more details.
- overriding-local-map (progn
- (set-keymap-parents isearch-mode-map
- (nconc (current-minor-mode-maps)
+ overriding-local-map (progn
+ (set-keymap-parents isearch-mode-map
+ (nconc (current-minor-mode-maps)
(and (current-local-map)
(list (current-local-map)))))
- isearch-mode-map)
+ isearch-mode-map)
isearch-selected-frame (selected-frame)
)
;; like switch buffers and start another isearch, and return.
;; (condition-case nil
(isearch-done t t)
- ;;#### What does this mean? There is no such condition!
+ ;;#### What does this mean? There is no such condition!
;; (exit nil)) ; was recursive editing
(unwind-protect
backwards."
(interactive)
(if (and delete-key-deletes-forward
- (case (device-type)
- ('tty (eq tty-erase-char ?\C-h))
- ('x (not (x-keysym-on-keyboard-sans-modifiers-p 'backspace)))))
+ (case (device-type)
+ ('tty (eq tty-erase-char ?\C-h))
+ ('x (not (x-keysym-on-keyboard-sans-modifiers-p 'backspace)))))
(isearch-delete-char)
(isearch-mode-help)))
(setq isearch-case-fold-search
(no-upper-case-p isearch-string isearch-regexp)))
(setq isearch-mode (if case-fold-search
- (if isearch-case-fold-search
- " Isearch" ;As God Intended Mode
+ (if isearch-case-fold-search
+ " Isearch" ;As God Intended Mode
" ISeARch") ;Warn about evil case via StuDLYcAps.
" Isearch")))
;; Helper for isearch-complete and isearch-complete-edit
;; Return t if completion OK, nil if no completion exists.
(let* ((ring (if isearch-regexp regexp-search-ring search-ring))
- (alist (mapcar (function (lambda (string) (list string))) ring))
- (completion-ignore-case case-fold-search)
- (completion (try-completion isearch-string alist)))
+ (alist (mapcar (function (lambda (string) (list string))) ring))
+ (completion-ignore-case case-fold-search)
+ (completion (try-completion isearch-string alist)))
(cond
((eq completion t)
;; isearch-string stays the same
(< (point) isearch-opoint)))
"overwrapped "
(if isearch-wrapped "wrapped "))
- (if isearch-word "word ")
- (if isearch-regexp "regexp ")
- (if nonincremental "search" "I-search")
- (if isearch-forward nil " backward")
+ (if isearch-word "word ")
+ (if isearch-regexp "regexp ")
+ (if nonincremental "search" "I-search")
+ (if isearch-forward nil " backward")
": "
- )))
+ )))
(aset m 0 (upcase (aref m 0)))
(gettext m)))
"Eval BODY with `case-fold-search' let to nil if STRING contains
uppercase letters and `search-caps-disable-folding' is t."
`(let ((case-fold-search
- (if (and case-fold-search search-caps-disable-folding)
- (isearch-no-upper-case-p ,string)
- case-fold-search)))
+ (if (and case-fold-search search-caps-disable-folding)
+ (isearch-no-upper-case-p ,string)
+ case-fold-search)))
,@body))
(make-obsolete 'with-caps-disable-folding 'with-search-caps-disable-folding)
(put 'with-caps-disable-folding 'lisp-indent-function 1)
(modify-syntax-entry ?\276 "_" table) ; threequarters
(modify-syntax-entry ?\277 "_" table) ; questiondown
;;
- ;; the upper-case characters (plus "multiply" and "ssharp")
+ ;; the upper-case characters (plus "multiply" and "ssharp")
;;
(modify-syntax-entry ?\300 "w" table) ; Agrave
(modify-syntax-entry ?\301 "w" table) ; Aacute
(list
(list 'quote
(list downcase nil nil nil))))))))
-
+
(?\300 ?\340) ; Agrave
(?\301 ?\341) ; Aacute
(?\302 ?\342) ; Acircumflex
;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;; Commentary:
-;;
+;;
;; This will hopefully turn into an interface to the SXEmacs issue
;; tracker. For now, it is basically a clone of xemacsbug with a
;; couple of things changed to suit SXEmacs conditions.
It takes the format (HEADER . VALUE) where both HEADER and VALUE are
strings. See `compose-mail'."
:group 'sxemacsbug
- :type '(repeat
- (cons (string :tag "Header")
+ :type '(repeat
+ (cons (string :tag "Header")
(string :tag "Value"))))
(defcustom report-sxemacs-bug-beta-address "SXEmacs Devel <sxemacs-devel@sxemacs.org>"
It takes the format (HEADER . VALUE) where both HEADER and VALUE are
strings. See `compose-mail'."
:group 'sxemacsbug
- :type '(repeat
- (cons (string :tag "Header")
+ :type '(repeat
+ (cons (string :tag "Header")
(string :tag "Value"))))
(defvar report-sxemacs-bug-orig-text nil
any C and lisp back-traces that you may have.
\(setq stack-trace-on-error t\), or \(setq debug-on-error t\) if you
are familiar with the debugger, to get a lisp back-trace.
-To get a core file for the C back-trace on a GNU/Linux system do
+To get a core file for the C back-trace on a GNU/Linux system do
'ulimit -c unlimited' in the shell prior to starting SXEmacs.
Type \\[report-sxemacs-bug-info] to visit in Info the SXEmacs Manual section
"Display the help buffer for `report-sxemacs-bug'."
(declare-fboundp
(with-electric-help
- #'(lambda ()
+ #'(lambda ()
(define-key (current-local-map) "\C-c\C-i" 'report-sxemacs-bug-info)
(princ (substitute-command-keys report-sxemacs-bug-help)) nil) "*Bug Help*")))
This is a convenience for reporting SXEmacs issues at
http://issues.sxemacs.org/. Returns t if any backtrace buffers are
found and saved, nil otherwise."
- (let ((ctrace (or (get-buffer (concat "*gdb-sxemacs-"
+ (let ((ctrace (or (get-buffer (concat "*gdb-sxemacs-"
emacs-program-version
"*"))
(get-buffer "*gdb-sxemacs*")))
(write-region (point-min) (point-max) file))
t)
nil)))
-
+
(defconst report-sxemacs-bugzilla-notrace
"Thank you very much for taking the time to report a problem with SXEmacs
========================================================================
(insert report-sxemacs-bugzilla-notrace)
(toggle-read-only 1)
(pop-to-buffer (get-buffer "Reporting Bugs"))
- (view-minor-mode
+ (view-minor-mode
nil #'(lambda (&rest not-used-buffer)
(kill-buffer (get-buffer "Reporting Bugs"))
(jump-to-register ?S)
;jwz: this is preloaded so don't ;;;###autoload
(defvar auto-gc-threshold (/ gc-cons-threshold 3)
- "*GC when this many bytes have been consed since the last GC,
+ "*GC when this many bytes have been consed since the last GC,
and the user has been idle for `auto-save-timeout' seconds.")
(defun auto-save-itimer ()
(let ((n 33))
(while (<= n 255)
(if (not (= n 127))
- (define-key global-map n 'self-insert-command))
+ (define-key global-map n 'self-insert-command))
(setq n (1+ n))))
(define-key global-map " " 'self-insert-command)
;; New FSF19 bindings: C-x n as a prefix for narrowing commands.
(define-key global-map "\C-xn" (let ((map (make-sparse-keymap)))
- (set-keymap-name map 'narrowing-prefix)
- map))
+ (set-keymap-name map 'narrowing-prefix)
+ map))
(put 'narrow-to-region 'disabled t)
(define-key global-map "\C-xnn" 'narrow-to-region)
(define-key global-map "\C-xnw" 'widen)
;; New FSF19 bindings: C-x r as a prefix for register commands
(define-key global-map "\C-xr" (let ((map (make-sparse-keymap)))
- (set-keymap-name map 'rectangle-prefix)
- map))
+ (set-keymap-name map 'rectangle-prefix)
+ map))
(define-key global-map "\C-xr\C-@" 'point-to-register)
(define-key global-map "\C-xr " 'point-to-register)
(define-key global-map "\C-xrj" 'jump-to-register)
;; expected behavior even in, for example, vi-mode.
;; We use here symbolic names, assuming that the corresponding keys will
-;; generate these keysyms. This is not true on Suns, but x-win-sun.el
+;; generate these keysyms. This is not true on Suns, but x-win-sun.el
;; fixes that. If it turns out that the semantics of these keys should
;; differ from server to server, this should be moved into server-specific
;; files, but these appear to be the standard Motif and PC bindings.
(define-key global-map 'delete 'backward-or-forward-delete-char)
(define-key global-map '(meta delete) 'backward-or-forward-kill-word)
(define-key global-map [(control x) (delete)]
- 'backward-or-forward-kill-sentence)
+ 'backward-or-forward-kill-sentence)
(define-key global-map 'kp-delete 'backward-or-forward-delete-char)
(define-key global-map '(meta kp-delete) 'backward-or-forward-kill-word)
(define-key global-map [(control x) (kp-delete)]
(if (or (null defn) (integerp defn))
(error "%s is undefined" (key-description key))
(if (or (stringp defn) (vectorp defn))
- (setq defn (key-binding defn))) ;; a keyboard macro
+ (setq defn (key-binding defn))) ;; a keyboard macro
(insert (format "%s" defn)))))
(defun read-command-or-command-sexp (prompt)
;; commandp (as does 'read-command') but that is not easy to do
;; because we must supply arg4 = require-match = nil for sexp case.
(let ((result (car (read-from-string
- (completing-read prompt obarray 'commandp)))))
+ (completing-read prompt obarray 'commandp)))))
(if (and (consp result)
- (not (eq (car result) 'lambda)))
- `(lambda ()
+ (not (eq (car result) 'lambda)))
+ `(lambda ()
(interactive)
,result)
result)))
the documentation for `lookup-key' for more information."
(let ((map (current-local-map)))
(if map
- (lookup-key map keys accept-defaults)
- nil)))
+ (lookup-key map keys accept-defaults)
+ nil)))
(defun global-key-binding (keys &optional accept-defaults)
"Return the binding for command KEYS in current global keymap only.
that local binding will continue to shadow any global binding."
;;(interactive "KSet key globally: \nCSet key %s to command: ")
(interactive (list (setq key (read-key-sequence "Set key globally: "))
- ;; Command sexps are allowed here so that this arg
- ;; may be supplied interactively via insert-key-binding.
- (read-command-or-command-sexp
- (format "Set key %s to command: "
- (key-description key)))))
+ ;; Command sexps are allowed here so that this arg
+ ;; may be supplied interactively via insert-key-binding.
+ (read-command-or-command-sexp
+ (format "Set key %s to command: "
+ (key-description key)))))
(define-key (current-global-map) key command)
nil)
which is shared with other buffers in the same major mode."
;;(interactive "KSet key locally: \nCSet key %s locally to command: ")
(interactive (list (setq key (read-key-sequence "Set key locally: "))
- ;; Command sexps are allowed here so that this arg
- ;; may be supplied interactively via insert-key-binding.
- (read-command-or-command-sexp
- (format "Set key %s locally to command: "
- (key-description key)))))
+ ;; Command sexps are allowed here so that this arg
+ ;; may be supplied interactively via insert-key-binding.
+ (read-command-or-command-sexp
+ (format "Set key %s locally to command: "
+ (key-description key)))))
(if (null (current-local-map))
(use-local-map (make-sparse-keymap)))
(define-key (current-local-map) key command)
If optional argument ACCEPT-DEFAULT is non-nil, recognize default
bindings; see the description of `lookup-key' for more details about this."
(let ((tail minor-mode-map-alist)
- a s v)
+ a s v)
(while tail
(setq a (car tail)
- tail (cdr tail))
+ tail (cdr tail))
(and (consp a)
- (symbolp (setq s (car a)))
- (boundp s)
- (symbol-value s)
- ;; indirect-function deals with autoloadable keymaps
- (setq v (indirect-function (cdr a)))
- (setq v (lookup-key v key accept-default))
- ;; Terminate loop, with v set to non-nil value
- (setq tail nil)))
+ (symbolp (setq s (car a)))
+ (boundp s)
+ (symbol-value s)
+ ;; indirect-function deals with autoloadable keymaps
+ (setq v (indirect-function (cdr a)))
+ (setq v (lookup-key v key accept-default))
+ ;; Terminate loop, with v set to non-nil value
+ (setq tail nil)))
v))
(defun current-minor-mode-maps ()
"Return a list of keymaps for the minor modes of the current buffer."
(let ((l '())
- (tail minor-mode-map-alist)
- a s v)
+ (tail minor-mode-map-alist)
+ a s v)
(while tail
(setq a (car tail)
- tail (cdr tail))
+ tail (cdr tail))
(and (consp a)
- (symbolp (setq s (car a)))
- (boundp s)
- (symbol-value s)
- ;; indirect-function deals with autoloadable keymaps
- (setq v (indirect-function (cdr a)))
- (setq l (cons v l))))
+ (symbolp (setq s (car a)))
+ (boundp s)
+ (symbol-value s)
+ ;; indirect-function deals with autoloadable keymaps
+ (setq v (indirect-function (cdr a)))
+ (setq l (cons v l))))
(nreverse l)))
\f
(let ((map (make-sparse-keymap name)))
(fset name map)
(cond ((not mapvar)
- (set name map))
- ((eq mapvar 't)
- )
- (t
- (set mapvar map)))
+ (set name map))
+ ((eq mapvar 't)
+ )
+ (t
+ (set mapvar map)))
name))
\f
Optional arg NO-MICE means that button events are not allowed."
(if (and events (symbolp events)) (setq events (vector events)))
(cond ((stringp events)
- events)
+ events)
((not (vectorp events))
- (signal 'wrong-type-argument (list 'vectorp events)))
+ (signal 'wrong-type-argument (list 'vectorp events)))
((let* ((length (length events))
- (string (make-string length 0))
- c ce
- (i 0))
- (while (< i length)
- (setq ce (aref events i))
- (or (eventp ce) (setq ce (character-to-event ce)))
- ;; Normalize `c' to `?c' and `(control k)' to `?\C-k'
- ;; By passing t for the `allow-meta' arg we could get kbd macros
- ;; with meta in them to translate to the string form instead of
- ;; the list/symbol form; but I expect that would cause confusion,
- ;; so let's use the list/symbol form whenever there's
- ;; any ambiguity.
- (setq c (event-to-character ce))
- (if (and c
- character-set-property
- (key-press-event-p ce))
- (cond ((symbolp (event-key ce))
- (if (get (event-key ce) character-set-property)
- ;; Don't use a string for `backspace' and `tab' to
- ;; avoid that unpleasant little ambiguity.
- (setq c nil)))
- ((and (= (event-modifier-bits ce) 1) ;control
- (integerp (event-key ce)))
- (let* ((te (character-to-event c)))
- (if (and (symbolp (event-key te))
- (get (event-key te) character-set-property))
- ;; Don't "normalize" (control i) to tab
- ;; to avoid the ambiguity in the other direction
- (setq c nil))
- (deallocate-event te)))))
- (if c
- (aset string i c)
- (setq i length string nil))
- (setq i (1+ i)))
- string))
+ (string (make-string length 0))
+ c ce
+ (i 0))
+ (while (< i length)
+ (setq ce (aref events i))
+ (or (eventp ce) (setq ce (character-to-event ce)))
+ ;; Normalize `c' to `?c' and `(control k)' to `?\C-k'
+ ;; By passing t for the `allow-meta' arg we could get kbd macros
+ ;; with meta in them to translate to the string form instead of
+ ;; the list/symbol form; but I expect that would cause confusion,
+ ;; so let's use the list/symbol form whenever there's
+ ;; any ambiguity.
+ (setq c (event-to-character ce))
+ (if (and c
+ character-set-property
+ (key-press-event-p ce))
+ (cond ((symbolp (event-key ce))
+ (if (get (event-key ce) character-set-property)
+ ;; Don't use a string for `backspace' and `tab' to
+ ;; avoid that unpleasant little ambiguity.
+ (setq c nil)))
+ ((and (= (event-modifier-bits ce) 1) ;control
+ (integerp (event-key ce)))
+ (let* ((te (character-to-event c)))
+ (if (and (symbolp (event-key te))
+ (get (event-key te) character-set-property))
+ ;; Don't "normalize" (control i) to tab
+ ;; to avoid the ambiguity in the other direction
+ (setq c nil))
+ (deallocate-event te)))))
+ (if c
+ (aset string i c)
+ (setq i length string nil))
+ (setq i (1+ i)))
+ string))
(t
- (let* ((length (length events))
- (new (copy-sequence events))
- event mods key
- (i 0))
- (while (< i length)
- (setq event (aref events i))
- (cond ((key-press-event-p event)
- (setq mods (event-modifiers event)
- key (event-key event))
- (if (numberp key)
- (setq key (intern (make-string 1 key))))
- (aset new i (if mods
- (nconc mods (cons key nil))
- key)))
- ((misc-user-event-p event)
- (aset new i (list 'menu-selection
- (event-function event)
- (event-object event))))
- ((or (button-press-event-p event)
- (button-release-event-p event))
- (if no-mice
- (error
- "Mouse events can't be saved in keyboard macros."))
- (setq mods (event-modifiers event)
- key (intern (format "button%d%s"
- (event-button event)
- (if (button-release-event-p event)
- "up" ""))))
- (aset new i (if mods
- (nconc mods (cons key nil))
- key)))
- ((or (and event (symbolp event))
- (and (consp event) (symbolp (car event))))
- (aset new i event))
- (t
- (signal 'wrong-type-argument (list 'eventp event))))
- (setq i (1+ i)))
- new))))
+ (let* ((length (length events))
+ (new (copy-sequence events))
+ event mods key
+ (i 0))
+ (while (< i length)
+ (setq event (aref events i))
+ (cond ((key-press-event-p event)
+ (setq mods (event-modifiers event)
+ key (event-key event))
+ (if (numberp key)
+ (setq key (intern (make-string 1 key))))
+ (aset new i (if mods
+ (nconc mods (cons key nil))
+ key)))
+ ((misc-user-event-p event)
+ (aset new i (list 'menu-selection
+ (event-function event)
+ (event-object event))))
+ ((or (button-press-event-p event)
+ (button-release-event-p event))
+ (if no-mice
+ (error
+ "Mouse events can't be saved in keyboard macros."))
+ (setq mods (event-modifiers event)
+ key (intern (format "button%d%s"
+ (event-button event)
+ (if (button-release-event-p event)
+ "up" ""))))
+ (aset new i (if mods
+ (nconc mods (cons key nil))
+ key)))
+ ((or (and event (symbolp event))
+ (and (consp event) (symbolp (car event))))
+ (aset new i event))
+ (t
+ (signal 'wrong-type-argument (list 'eventp event))))
+ (setq i (1+ i)))
+ new))))
\f
(defun next-key-event ()
(defun library-all-completions (FILE SEARCH-PATH &optional FULL FAST)
"Return all completions for FILE in any directory on SEARCH-PATH.
-If optional third argument FULL is non-nil, returned pathnames should be
+If optional third argument FULL is non-nil, returned pathnames should be
absolute rather than relative to some directory on the SEARCH-PATH.
If optional fourth argument FAST is non-nil, don't sort the completions,
or remove duplicates."
;; It's an absolute file name, so don't need SEARCH-PATH
(progn
(setq FILE (expand-file-name FILE))
- (file-name-all-completions
+ (file-name-all-completions
(file-name-nondirectory FILE) (file-name-directory FILE)))
(let ((subdir (file-name-directory FILE))
(file (file-name-nondirectory FILE))
all-completions)
;; Make list of completions in each directory on SEARCH-PATH
(while SEARCH-PATH
- (let* ((dir (concat (file-name-as-directory
+ (let* ((dir (concat (file-name-as-directory
(expand-file-name (car SEARCH-PATH)))
subdir))
(dir-prefix (if FULL dir subdir)))
(if (file-directory-p dir)
- (let ((subdir-completions
+ (let ((subdir-completions
(file-name-all-completions file dir)))
(while subdir-completions
- (setq all-completions
+ (setq all-completions
(cons (concat dir-prefix (car subdir-completions))
all-completions))
(setq subdir-completions (cdr subdir-completions))))))
- (setq SEARCH-PATH (cdr SEARCH-PATH)))
+ (setq SEARCH-PATH (cdr SEARCH-PATH)))
(if FAST all-completions
(let ((sorted (nreverse (sort all-completions 'string<)))
compressed)
;;=== Completion caching ==================================================
(defconst lib-complete:cache nil
- "Used within `read-library' and `read-library-internal' to prevent
+ "Used within `read-library' and `read-library-internal' to prevent
costly repeated calls to `library-all-completions'.
Format is a list of lists of the form
(defun lib-complete:get-completion-table (FILE PATH FILTER)
(let* ((subdir (file-name-directory FILE))
(root (file-name-nondirectory FILE))
- (PATH
- (mapcar
+ (PATH
+ (mapcar
(function (lambda (dir) (file-name-as-directory
(expand-file-name (or dir "")))))
PATH))
(key (vector PATH subdir FILTER))
- (real-dirs
+ (real-dirs
(if subdir
(mapcar (function (lambda (dir) (concat dir subdir))) PATH)
PATH))
(path-modtimes
- (mapcar
- (function (lambda (fn) (if fn (nth 5 (file-attributes fn)))))
+ (mapcar
+ (function (lambda (fn) (if fn (nth 5 (file-attributes fn)))))
real-dirs))
(cache-entry (assoc key lib-complete:cache))
(cache-records (cdr cache-entry)))
;; Look for cached entry
(catch 'table
(while cache-records
- (if (and
+ (if (and
(lib-complete:better-root (nth 0 (car cache-records)) root)
(equal (nth 1 (car cache-records)) path-modtimes))
(throw 'table (nth 2 (car cache-records))))
(setq cache-records (cdr cache-records)))
;; Otherwise build completions
- (let ((completion-list
+ (let ((completion-list
(progn-with-message "(building completion table...)"
(library-all-completions FILE PATH nil 'fast)))
(completion-table (make-vector 127 0)))
(while completion-list
(let ((completion
- (if (or (not FILTER)
- (file-directory-p (car completion-list)))
+ (if (or (not FILTER)
+ (file-directory-p (car completion-list)))
(car completion-list)
(funcall FILTER (car completion-list)))))
(if completion
(intern completion completion-table)))
(setq completion-list (cdr completion-list)))
;; Cache the completions
- (lib-complete:cache-completions key root
+ (lib-complete:cache-completions key root
path-modtimes completion-table)
completion-table))))
-(defvar lib-complete:max-cache-size 40
+(defvar lib-complete:max-cache-size 40
"*Maximum number of search paths which are cached.")
(defun lib-complete:cache-completions (key root modtimes table)
(if (or (equal root (nth 0 (car cache-records)))
(lib-complete:better-root root (nth 0 (car cache-records))))
nil
- (setq new-cache-records
+ (setq new-cache-records
(cons (car cache-records) new-cache-records)))
(setq cache-records (cdr cache-records))))
;; Add entry to front of cache
((eq FLAG 'lambda) (and (intern-soft FILE completion-table) t))
)))
-(defun read-library (PROMPT SEARCH-PATH &optional DEFAULT MUST-MATCH
+(defun read-library (PROMPT SEARCH-PATH &optional DEFAULT MUST-MATCH
FULL FILTER)
"Read library name, prompting with PROMPT and completing in directories
from SEARCH-PATH. A nil in the search path represents the current
Default to DEFAULT if user enters a null string.
Optional fourth arg MUST-MATCH non-nil means require existing file's name.
Non-nil and non-t means also require confirmation after completion.
-Optional fifth argument FULL non-nil causes a full pathname, rather than a
+Optional fifth argument FULL non-nil causes a full pathname, rather than a
relative pathname, to be returned. Note that FULL implies MUST-MATCH.
Optional sixth argument FILTER can be used to provide a function to
filter the completions. This function is passed the filename, and should
- return a transformed filename (possibly a null transformation) or nil,
+ return a transformed filename (possibly a null transformation) or nil,
indicating that the filename should not be included in the completions."
(let* ((read-library-internal-search-path SEARCH-PATH)
- (library (completing-read PROMPT 'read-library-internal
+ (library (completing-read PROMPT 'read-library-internal
FILTER (or MUST-MATCH FULL) nil)))
- (cond
+ (cond
((equal library "") DEFAULT)
(FULL (locate-file library read-library-internal-search-path
'(".el" ".el.gz" ".elc")))
(declare (special read-library-internal-search-path))
(let ((read-library-internal-search-path load-path))
(completing-read prompt
- 'read-library-internal
- (lambda (fn)
+ 'read-library-internal
+ (lambda (fn)
(cond
((string-match #r"\.el\(\.gz\|\.Z\)?$" fn)
(substring fn 0 (match-beginning 0)))))
(defun load-library (library)
"Load the library named LIBRARY.
This is an interface to the function `load'."
- (interactive
+ (interactive
(list (read-library "Load library: " load-path nil nil nil
- (function (lambda (fn)
- (cond
+ (function (lambda (fn)
+ (cond
((string-match "\\.elc?$" fn)
(substring fn 0 (match-beginning 0))))))
- )))
+ )))
(load library))
;;=== find-library with completion (Author: Bob Weiner) ===================
with a prefix argument, this prompts for the coding system. Optional third
argument DISPLAY-FUNCTION must take two arguments, the filename to display
and CODESYS. The default for DISPLAY-FUNCTION is `find-file'."
- (interactive
+ (interactive
(list (read-library-name "Find library: ")
(if current-prefix-arg
(read-coding-system "Coding System: "))))
(let ((path (if (or (null library) (equal library ""))
nil
(locate-file library load-path
- '("" ".el" ".el.gz" ".el.Z")))))
+ '("" ".el" ".el.gz" ".el.Z")))))
(if path (funcall (if (fboundp display-function)
display-function 'find-file)
path codesys)
the \".el\" suffix. Under XEmacs/Mule, the optional second argument CODESYS
specifies the coding system to use when decoding the file. Interactively,
with a prefix argument, this prompts for the coding system."
- (interactive
+ (interactive
(list (read-library-name "Find library in other window: ")
(if current-prefix-arg
(read-coding-system "Coding System: "))))
the \".el\" suffix. Under XEmacs/Mule, the optional second argument CODESYS
specifies the coding system to use when decoding the file. Interactively,
with a prefix argument, this prompts for the coding system."
- (interactive
+ (interactive
(list (read-library-name "Find library in other frame: ")
(if current-prefix-arg
(read-coding-system "Coding System: "))))
"Kill the byte-compile Compile Log buffers")
-(defvar lisp-initd-gather-func #'directory-files
+(defvar lisp-initd-gather-func #'directory-files
"Function used to gather the files used in init. For acceptable
arguments see `directory-files'. The function is expected to return a
sorted list of absolute pathnames, accept and honor the MATCH argument
(let* ((initd-dir (file-name-as-directory
(expand-file-name
(or dir lisp-initd-dir))))
- (initd-file (or file lisp-initd-basename))
+ (initd-file (or file lisp-initd-basename))
(initd-el (expand-file-name (concat initd-file ".el")
- (paths-construct-path
+ (paths-construct-path
(list initd-dir ".."))))
- (initd-elc (concat initd-el "c"))
- (initd-files (funcall lisp-initd-gather-func initd-dir
+ (initd-elc (concat initd-el "c"))
+ (initd-files (funcall lisp-initd-gather-func initd-dir
t "^.*\.el$" nil t))
(init-file (if lisp-initd-byte-compile-elisp initd-elc initd-el))
- init-buffer)
+ init-buffer)
;; No use in keeping an outdate byte-compiled file...
(when (and (file-exists-p initd-el)
(message "Recompiling init files....")
(setq init-buffer (generate-new-buffer (concat "*" initd-el "*")))
(with-current-buffer init-buffer
- (set-visited-file-name initd-el)
+ (set-visited-file-name initd-el)
(insert ";; This is an automatically generated file.\n"
";; DO NOT EDIT\n"
";;\n")
(insert "(message \"Compiled " initd-dir " loading started\")\n")
- (mapc
+ (mapc
#'(lambda (current)
(condition-case err
(insert "(condition-case err (progn\n"
";; ------------------------------------\n"
";; " current "\n"
- (save-excursion
- (save-restriction
+ (save-excursion
+ (save-restriction
(with-temp-buffer
(insert-file-contents current)
(eval-buffer)
"\n"
";; ----------------------------------\n"
")\n"
- "(error (message \"Error loading " current
+ "(error (message \"Error loading " current
": \\\"%S\\\" (signal:\'%S\' . data:\'%S\')\" "
"err (car err) (cdr err))))\n"
";; ----------------------------------\n\n")
(error
(progn
- (insert "(warn \"\\\"" current
+ (insert "(warn \"\\\"" current
"\\\" not inserted "
- (replace-regexp-in-string
+ (replace-regexp-in-string
"\"" "\\\""
(format (concat "due to syntax error: %S"
" (signal:%S . data:%S)")
either a complete path, or the last element of a path. If the latter,
DIR is expanded against the _parent_ directory of `lisp-initd-dir'.
-Optional file arg, FILE is the name of the file to be loaded.
+Optional file arg, FILE is the name of the file to be loaded.
If it is omitted, `lisp-initd-basename' is used.
See `lisp-initd-compile'."
(when dir
(unless (string-match "/" dir)
(setq dir (file-name-as-directory
- (expand-file-name dir (paths-construct-path
+ (expand-file-name dir (paths-construct-path
(list lisp-initd-dir "..")))))))
(when current-prefix-arg
(setq file (read-string "File: ")))
-
+
(lisp-initd-compile dir file t))
(provide 'lisp-initd)
-
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Synched up with: FSF 20.2.
-
+
;;; Commentary:
;; This minor mode adds some services to Emacs-Lisp editing mode.
;; First, it knows about the header conventions for library packages.
;; One entry point supports generating synopses from a library directory.
;; Another can be used to check for missing headers in library files.
-;;
+;;
;; Another entry point automatically addresses bug mail to a package's
;; maintainer or author.
;; This file is an example of the header conventions. Note the following
;; features:
-;;
+;;
;; * Header line --- makes it possible to extract a one-line summary of
;; the package's uses automatically for use in library synopses, KWIC
;; indexes and the like.
-;;
+;;
;; Format is three semicolons, followed by the filename, followed by
;; three dashes, followed by the summary. All fields space-separated.
-;;
+;;
;; * Author line --- contains the name and net address of at least
;; the principal author.
-;;
+;;
;; If there are multiple authors, they should be listed on continuation
;; lines led by ;;<TAB><TAB> (or multiple blanks), like this:
-;;
+;;
;; ;; Author: Ashwin Ram <Ram-Ashwin@cs.yale.edu>
;; ;; Dave Sill <de5@ornl.gov>
;; ;; David Lawrence <tale@pawl.rpi.edu>
;; ;; Joe Wells <jbw@maverick.uswest.com>
;; ;; Dave Brennan <brennan@hal.com>
;; ;; Eric Raymond <esr@snark.thyrsus.com>
-;;
+;;
;; This field may have some special values; notably "FSF", meaning
;; "Free Software Foundation".
-;;
+;;
;; * Maintainer line --- should be a single name/address as in the Author
;; line, or an address only, or the string "FSF". If there is no maintainer
;; line, the person(s) in the Author field are presumed to be it. The example
;; that does "send mail to the author" without having to mine the name out by
;; hand. Please be careful about surrounding the network address with <> if
;; there's also a name in the field.
-;;
+;;
;; * Created line --- optional, gives the original creation date of the
;; file. For historical interest, basically.
-;;
+;;
;; * Version line --- intended to give the reader a clue if they're looking
;; at a different version of the file than the one they're accustomed to. This
;; may be an RCS or SCCS header.
-;;
+;;
;; * Adapted-By line --- this is for FSF's internal use. The person named
;; in this field was the one responsible for installing and adapting the
;; package for the distribution. (This file doesn't have one because the
;; author *is* one of the maintainers.)
-;;
+;;
;; * Keywords line --- used by the finder code (now under construction)
;; for finding Emacs Lisp code related to a topic.
;;
;;
;; * Commentary line --- enables Lisp code to find the developer's and
;; maintainers' explanations of the package internals.
-;;
+;;
;; * Change log line --- optional, exists to terminate the commentary
;; section and start a change-log part, if one exists.
-;;
+;;
;; * Code line --- exists so Lisp can know where commentary and/or
;; change-log sections end.
-;;
+;;
;; * Footer line --- marks end-of-file so it can be distinguished from
;; an expanded formfeed or the results of truncation.
(defun lm-last-modified-date (&optional file)
"Return the modify-date given in file FILE, or current buffer if FILE is nil."
- (save-excursion
+ (save-excursion
(if file
(find-file file))
(prog1
(lm-code-mark) t))
(format "%s %s %s"
(buffer-substring (match-beginning 3) (match-end 3))
- (nth (string-to-int
+ (nth (string-to-int
(buffer-substring (match-beginning 2) (match-end 2)))
'("" "Jan" "Feb" "Mar" "Apr" "May" "Jun"
"Jul" "Aug" "Sep" "Oct" "Nov" "Dec"))
(defun lm-version (&optional file)
"Return the version listed in file FILE, or current buffer if FILE is nil.
This can be found in an RCS or SCCS header to crack it out of."
- (save-excursion
+ (save-excursion
(if file
(find-file file))
(prog1
(buffer-substring (match-beginning 1) (match-end 1)))
;; Look for an SCCS header
- ((re-search-forward
+ ((re-search-forward
(concat
(regexp-quote "@(#)")
(regexp-quote (file-name-nondirectory (buffer-file-name)))
(let ((package (lm-get-package-name))
(addr (lm-maintainer))
(version (lm-version)))
- (declare-fboundp
+ (declare-fboundp
(mail nil
(if addr
(concat (car addr) " <" (cdr addr) ">")
(defvar lisp-imenu-generic-expression
'(
- (nil
+ (nil
#r"^\s-*(def\(un\|subst\|macro\|advice\)\s-+\([-A-Za-z0-9+*|:]+\)" 2)
- ("Variables"
+ ("Variables"
#r"^\s-*(def\(var\|const\|custom\)\s-+\([-A-Za-z0-9+*|:]+\)" 2)
- ("Types"
- #r"^\s-*(def\(group\|type\|struct\|class\|ine-condition\)\s-+\([-A-Za-z0-9+*|:]+\)"
+ ("Types"
+ #r"^\s-*(def\(group\|type\|struct\|class\|ine-condition\)\s-+\([-A-Za-z0-9+*|:]+\)"
2))
"Imenu generic expression for Lisp mode. See `imenu-generic-expression'.")
;; Look within the line for a ; following an even number of backslashes
;; after either a non-backslash or the line beginning.
(setq comment-start-skip (concat #r"\(\(^\|"
- "[^\\\\\n]"
- #r"\)\(\\\\\)*\);+ *"))
+ "[^\\\\\n]"
+ #r"\)\(\\\\\)*\);+ *"))
(make-local-variable 'comment-column)
(setq comment-column 40)
(make-local-variable 'comment-indent-function)
mode-popup-menu emacs-lisp-mode-popup-menu
mode-name "Emacs-Lisp")
(if (and (featurep 'menubar)
- current-menubar)
+ current-menubar)
(progn
;; make a local copy of the menubar, so our modes don't
;; change the global menubar
(setq mode-name "Lisp Interaction")
(setq mode-popup-menu lisp-interaction-mode-popup-menu)
(if (and (featurep 'menubar)
- current-menubar)
+ current-menubar)
(progn
;; make a local copy of the menubar, so our modes don't
;; change the global menubar
(beginning-of-line)
(let ((indent-point (point))
;; XEmacs change (remove paren-depth)
- state ;;paren-depth
- ;; setting this to a number inhibits calling hook
- (desired-indent nil)
- (retry t)
- calculate-lisp-indent-last-sexp containing-sexp)
+ state ;;paren-depth
+ ;; setting this to a number inhibits calling hook
+ (desired-indent nil)
+ (retry t)
+ calculate-lisp-indent-last-sexp containing-sexp)
(if parse-start
- (goto-char parse-start)
- (beginning-of-defun))
+ (goto-char parse-start)
+ (beginning-of-defun))
;; Find outermost containing sexp
(while (< (point) indent-point)
- (setq state (parse-partial-sexp (point) indent-point 0)))
+ (setq state (parse-partial-sexp (point) indent-point 0)))
;; Find innermost containing sexp
(while (and retry
state
;; XEmacs change (remove paren-depth)
- (> ;;(setq paren-depth (elt state 0))
+ (> ;;(setq paren-depth (elt state 0))
(elt state 0)
0))
- (setq retry nil)
- (setq calculate-lisp-indent-last-sexp (elt state 2))
- (setq containing-sexp (elt state 1))
- ;; Position following last unclosed open.
- (goto-char (1+ containing-sexp))
- ;; Is there a complete sexp since then?
- (if (and calculate-lisp-indent-last-sexp
+ (setq retry nil)
+ (setq calculate-lisp-indent-last-sexp (elt state 2))
+ (setq containing-sexp (elt state 1))
+ ;; Position following last unclosed open.
+ (goto-char (1+ containing-sexp))
+ ;; Is there a complete sexp since then?
+ (if (and calculate-lisp-indent-last-sexp
(> calculate-lisp-indent-last-sexp (point)))
- ;; Yes, but is there a containing sexp after that?
- (let ((peek (parse-partial-sexp calculate-lisp-indent-last-sexp
+ ;; Yes, but is there a containing sexp after that?
+ (let ((peek (parse-partial-sexp calculate-lisp-indent-last-sexp
indent-point 0)))
- (if (setq retry (car (cdr peek))) (setq state peek)))))
+ (if (setq retry (car (cdr peek))) (setq state peek)))))
(if retry
- nil
- ;; Innermost containing sexp found
- (goto-char (1+ containing-sexp))
- (if (not calculate-lisp-indent-last-sexp)
+ nil
+ ;; Innermost containing sexp found
+ (goto-char (1+ containing-sexp))
+ (if (not calculate-lisp-indent-last-sexp)
;; indent-point immediately follows open paren.
;; Don't call hook.
- (setq desired-indent (current-column))
+ (setq desired-indent (current-column))
;; Find the start of first element of containing sexp.
(parse-partial-sexp (point) calculate-lisp-indent-last-sexp 0 t)
(cond ((looking-at "\\s(")
;; Call indentation hook except when overridden by lisp-indent-offset
;; or if the desired indentation has already been computed.
(let ((normal-indent (current-column)))
- (cond ((elt state 3)
- ;; Inside a string, don't change indentation.
- (goto-char indent-point)
- (skip-chars-forward " \t")
- (current-column))
- (desired-indent)
- ((and (boundp 'lisp-indent-function)
- lisp-indent-function
- (not retry))
- (or (funcall lisp-indent-function indent-point state)
- normal-indent))
+ (cond ((elt state 3)
+ ;; Inside a string, don't change indentation.
+ (goto-char indent-point)
+ (skip-chars-forward " \t")
+ (current-column))
+ (desired-indent)
+ ((and (boundp 'lisp-indent-function)
+ lisp-indent-function
+ (not retry))
+ (or (funcall lisp-indent-function indent-point state)
+ normal-indent))
;; XEmacs change:
- ;; lisp-indent-offset shouldn't override lisp-indent-function !
- ((and (integerp lisp-indent-offset) containing-sexp)
- ;; Indent by constant offset
- (goto-char containing-sexp)
- (+ normal-indent lisp-indent-offset))
- (t
- normal-indent))))))
+ ;; lisp-indent-offset shouldn't override lisp-indent-function !
+ ((and (integerp lisp-indent-offset) containing-sexp)
+ ;; Indent by constant offset
+ (goto-char containing-sexp)
+ (+ normal-indent lisp-indent-offset))
+ (t
+ normal-indent))))))
(defun lisp-indent-function (indent-point state)
;; free reference to `calculate-lisp-indent-last-sexp'
(goto-char (1+ (elt state 1)))
(parse-partial-sexp (point) calculate-lisp-indent-last-sexp 0 t)
(if (and (elt state 2)
- (not (looking-at #r"\sw\|\s_")))
- ;; car of form doesn't seem to be a symbol
- (progn
- (if (not (> (save-excursion (forward-line 1) (point))
- calculate-lisp-indent-last-sexp))
- (progn (goto-char calculate-lisp-indent-last-sexp)
- (beginning-of-line)
- (parse-partial-sexp (point)
+ (not (looking-at #r"\sw\|\s_")))
+ ;; car of form doesn't seem to be a symbol
+ (progn
+ (if (not (> (save-excursion (forward-line 1) (point))
+ calculate-lisp-indent-last-sexp))
+ (progn (goto-char calculate-lisp-indent-last-sexp)
+ (beginning-of-line)
+ (parse-partial-sexp (point)
calculate-lisp-indent-last-sexp 0 t)))
- ;; Indent under the list or under the first sexp on the same
- ;; line as calculate-lisp-indent-last-sexp. Note that first
- ;; thing on that line has to be complete sexp since we are
- ;; inside the innermost containing sexp.
- (backward-prefix-chars)
- (current-column))
+ ;; Indent under the list or under the first sexp on the same
+ ;; line as calculate-lisp-indent-last-sexp. Note that first
+ ;; thing on that line has to be complete sexp since we are
+ ;; inside the innermost containing sexp.
+ (backward-prefix-chars)
+ (current-column))
(let ((function (buffer-substring (point)
(progn (forward-sexp 1) (point))))
method)
(defun lisp-indent-specform (count state indent-point normal-indent)
(let ((containing-form-start (elt state 1))
- (i count)
- body-indent containing-form-column)
+ (i count)
+ body-indent containing-form-column)
;; Move to the start of containing form, calculate indentation
;; to use for non-distinguished forms (> count), and move past the
;; function symbol. lisp-indent-function guarantees that there is at
;; Now find the start of the last form.
(parse-partial-sexp (point) indent-point 1 t)
(while (and (< (point) indent-point)
- (condition-case ()
- (progn
- (setq count (1- count))
- (forward-sexp 1)
- (parse-partial-sexp (point) indent-point 1 t))
- (error nil))))
+ (condition-case ()
+ (progn
+ (setq count (1- count))
+ (forward-sexp 1)
+ (parse-partial-sexp (point) indent-point 1 t))
+ (error nil))))
;; Point is sitting on first character of last (or count) sexp.
(if (> count 0)
- ;; A distinguished form. If it is the first or second form use double
- ;; lisp-body-indent, else normal indent. With lisp-body-indent bound
- ;; to 2 (the default), this just happens to work the same with if as
- ;; the older code, but it makes unwind-protect, condition-case,
- ;; with-output-to-temp-buffer, et. al. much more tasteful. The older,
- ;; less hacked, behavior can be obtained by replacing below with
- ;; (list normal-indent containing-form-start).
- (if (<= (- i count) 1)
- (list (+ containing-form-column (* 2 lisp-body-indent))
- containing-form-start)
- (list normal-indent containing-form-start))
+ ;; A distinguished form. If it is the first or second form use double
+ ;; lisp-body-indent, else normal indent. With lisp-body-indent bound
+ ;; to 2 (the default), this just happens to work the same with if as
+ ;; the older code, but it makes unwind-protect, condition-case,
+ ;; with-output-to-temp-buffer, et. al. much more tasteful. The older,
+ ;; less hacked, behavior can be obtained by replacing below with
+ ;; (list normal-indent containing-form-start).
+ (if (<= (- i count) 1)
+ (list (+ containing-form-column (* 2 lisp-body-indent))
+ containing-form-start)
+ (list normal-indent containing-form-start))
;; A non-distinguished form. Use body-indent if there are no
;; distinguished forms and this is the first undistinguished form,
;; or if this is the first undistinguished form and the preceding
;; distinguished form has indentation at least as great as body-indent.
(if (or (and (= i 0) (= count 0))
- (and (= count 0) (<= body-indent normal-indent)))
- body-indent
- normal-indent))))
+ (and (= count 0) (<= body-indent normal-indent)))
+ body-indent
+ normal-indent))))
(defun lisp-indent-defform (state indent-point)
(goto-char (car (cdr state)))
(if (and (> arg 0) (looking-at "#s(\\|#r[uU]?\"\\|#p\\["))
(goto-char (1+ (- (point) (- (match-end 0) (match-beginning 0))))))
(goto-char (or (scan-sexps (point) arg) (buffer-end arg)))
- (when (< arg 0)
+ (when (< arg 0)
(backward-prefix-chars)
;; XEmacs: evil hack! Skip back over #[sr] so that structures and raw
;; strings are read properly. the current cheesified syntax tables just
(interactive "_p")
(if (or (null count) (= count 0)) (setq count 1))
(if end-of-defun-function
- (if (> count 0)
+ (if (> count 0)
(dotimes (i count)
(funcall end-of-defun-function)))
(let ((first t))
;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc.
;; Copyright (C) 1996, 2000 Ben Wing.
-
+
;; Maintainer: SXEmacs Development Team
;; Keywords: extensions, dumped
(add-local-hook 'pre-command-hook 'list-mode-extent-pre-hook)
(set (make-local-variable 'next-line-add-newlines) nil)
(setq list-mode-extent nil)
-;; It is visually disconcerting to have the text cursor disappear within list
+;; It is visually disconcerting to have the text cursor disappear within list
;; buffers, especially when moving from window to window, so leave it
;; visible. -- Bob Weiner, 06/20/1999
; (set-specifier text-cursor-visible-p nil (current-buffer))
;; be the selected-frame at the point this is
;; run. We keep the selected-frame call around
;; just in case.
- (window-width (get-lru-window (last-nonminibuf-frame)))
+ (window-width (get-lru-window (last-nonminibuf-frame)))
80))))
(let ((count 0)
(max-width 0)
(setq max-width len))
(setq count (1+ count)
tail (cdr tail)))))
-
+
(setq max-width (+ 2 max-width)) ; at least two chars between cols
(setq old-max-width max-width)
(let ((rows (let ((cols (min (/ win-width max-width) count)))
(setq max-width (/ win-width cols))
(if (/= (% count cols) 0) ; want ceiling...
(1+ (/ count cols))
- (/ count cols)))))))
+ (/ count cols)))))))
(when
(and cl-window-height
(> rows cl-window-height))
(if (/= indent 0)
(if bufferp
(indent-to indent 2)
- (while (progn (write-char ?\ )
- (setq column (1+ column))
- (< column indent)))))
+ (while (progn (write-char ?\ )
+ (setq column (1+ column))
+ (< column indent)))))
(setq indent (+ indent max-width))
(let ((start (point))
end)
(interactive)
(message "Making completion list...")
(let ((completions (all-completions (buffer-string)
- minibuffer-completion-table
- minibuffer-completion-predicate)))
+ minibuffer-completion-table
+ minibuffer-completion-predicate)))
(message nil)
(if (null completions)
- (progn
- (ding nil 'no-completion)
- (temp-minibuffer-message " [No completions]"))
- (with-output-to-temp-buffer "*Completions*"
+ (progn
+ (ding nil 'no-completion)
+ (temp-minibuffer-message " [No completions]"))
+ (with-output-to-temp-buffer "*Completions*"
(funcall completion-display-completion-list-function
(sort completions #'string-lessp))))))
-(define-derived-mode completion-list-mode list-mode
+(define-derived-mode completion-list-mode list-mode
"Completion List"
"Major mode for buffers showing lists of possible completions.
\\{completion-list-mode-map}"
;; It is no longer necessary. Instead use autoload.el to maintain them
;; for you. Just insert ";;;###autoload" before defuns or defmacros you
;; want to be autoloaded, or other forms you want copied into loaddefs.el
-;; (defvars, key definitions, etc.). For example,
+;; (defvars, key definitions, etc.). For example,
;; ;;;###autoload
;; (defun foobar () ....)
;; ;;;###autoload (define-key global-map "f" 'foobar)
(interactive "SFind source file for symbol: ") ; XEmacs
(let (built-in-file autoload-cons symbol-details)
(cond ((and (eq 'autoload
- (car-safe
- (setq autoload-cons
- (and (fboundp sym) (symbol-function sym)))))
- (or (and (or (null type) (eq 'defvar type))
- (eq (fifth autoload-cons) 'keymap))
- (and (or (null type) (eq 'defun type))
- (memq (fifth autoload-cons) '(nil macro)))))
- (return-from symbol-file (locate-library (second autoload-cons))))
- ((eq 'defvar type)
- ;; Load history entries corresponding to variables are just
- ;; symbols.
- (dolist (entry load-history)
- (when (memq sym (cdr entry))
- (return-from symbol-file (car entry)))))
- ((not (null type))
- ;; Non-variables have the type stored as the car of the entry.
- (dolist (entry load-history)
- (when (and (setq symbol-details (rassq sym (cdr entry)))
- (eq type (car symbol-details)))
- (return-from symbol-file (car entry)))))
- (t
- ;; If TYPE hasn't been specified, we need to check both for
- ;; variables and other symbols.
- (dolist (entry load-history)
- (when (or (memq sym (cdr entry))
- (rassq sym (cdr entry)))
- (return-from symbol-file (car entry))))))
+ (car-safe
+ (setq autoload-cons
+ (and (fboundp sym) (symbol-function sym)))))
+ (or (and (or (null type) (eq 'defvar type))
+ (eq (fifth autoload-cons) 'keymap))
+ (and (or (null type) (eq 'defun type))
+ (memq (fifth autoload-cons) '(nil macro)))))
+ (return-from symbol-file (locate-library (second autoload-cons))))
+ ((eq 'defvar type)
+ ;; Load history entries corresponding to variables are just
+ ;; symbols.
+ (dolist (entry load-history)
+ (when (memq sym (cdr entry))
+ (return-from symbol-file (car entry)))))
+ ((not (null type))
+ ;; Non-variables have the type stored as the car of the entry.
+ (dolist (entry load-history)
+ (when (and (setq symbol-details (rassq sym (cdr entry)))
+ (eq type (car symbol-details)))
+ (return-from symbol-file (car entry)))))
+ (t
+ ;; If TYPE hasn't been specified, we need to check both for
+ ;; variables and other symbols.
+ (dolist (entry load-history)
+ (when (or (memq sym (cdr entry))
+ (rassq sym (cdr entry)))
+ (return-from symbol-file (car entry))))))
(when (setq built-in-file (built-in-symbol-file sym type))
(if (equal built-in-file (file-truename built-in-file))
- ;; Probably a full path name:
- built-in-file
- ;; This is a bit heuristic, but shouldn't realistically be a
- ;; problem:
- (if (string-match "\.elc?$" built-in-file)
- (concat lisp-directory built-in-file)
- (concat source-directory "/src/" built-in-file))))))
+ ;; Probably a full path name:
+ built-in-file
+ ;; This is a bit heuristic, but shouldn't realistically be a
+ ;; problem:
+ (if (string-match "\.elc?$" built-in-file)
+ (concat lisp-directory built-in-file)
+ (concat source-directory "/src/" built-in-file))))))
(defun feature-symbols (feature)
"Return the file and list of symbols associated with a given FEATURE."
"Non-nil when the current emacs is SXEmacs.")
;; Can't make this constant for now because it causes an error in
-;; update-elc.el.
+;; update-elc.el.
(defvar source-lisp (file-name-directory (expand-file-name (nth 2 command-line-args))) "\
-Root of tree containing the Lisp source code for the current build.
+Root of tree containing the Lisp source code for the current build.
Differs from `lisp-directory' if this SXEmacs has been installed. ")
(defconst build-directory (expand-file-name ".." (expand-file-name ".." invocation-directory)) "\
-Root of tree containing object files and executables produced by build.
-Differs from `source-directory' if configured with --srcdir option, a practice
+Root of tree containing object files and executables produced by build.
+Differs from `source-directory' if configured with --srcdir option, a practice
recommended for developers.")
(defconst source-directory (expand-file-name ".." source-lisp) "\
-Root of tree containing source code for the current build.
+Root of tree containing source code for the current build.
Used during loadup and for documenting source of symbols defined in C.")
(defvar preloaded-file-list nil "\
;(start-profiling)
(defun compute-build-root (dir)
- "Given DIR as basis, traverse parent-wards until the cookie
+ "Given DIR as basis, traverse parent-wards until the cookie
file .sxemacs.source.tree is found."
(when (stringp dir)
(while (and (file-readable-p dir)
- (not (string-equal "/" dir))
- (not (file-exists-p
- (expand-file-name ".sxemacs.source.tree" dir))))
+ (not (string-equal "/" dir))
+ (not (file-exists-p
+ (expand-file-name ".sxemacs.source.tree" dir))))
(setq dir (expand-file-name ".." dir)))
dir))
(not (memq 'quick-build internal-error-checking)))
30000 3000000)))
-
+
;; This is awfully damn early to be getting an error, right?
(call-with-condition-handler 'really-early-error-handler
#'(lambda ()
(kill-buffer (current-buffer)))))
(let ((build-root (compute-build-root invocation-directory))
- (source-tree-root (getenv "SOURCE_TREE_ROOT"))
- (build-tree-root (getenv "BUILD_TREE_ROOT")))
+ (source-tree-root (getenv "SOURCE_TREE_ROOT"))
+ (build-tree-root (getenv "BUILD_TREE_ROOT")))
(setq load-path
- (list (expand-file-name "lisp" build-root)
- (expand-file-name "lisp" build-tree-root)
- (expand-file-name "lisp" source-tree-root)))
+ (list (expand-file-name "lisp" build-root)
+ (expand-file-name "lisp" build-tree-root)
+ (expand-file-name "lisp" source-tree-root)))
(setq module-load-path
- (list (expand-file-name "modules" build-root)
- (expand-file-name "modules" build-tree-root)
- (expand-file-name "modules" source-tree-root)))
- (unless (file-exists-p (car load-path))
- (setq load-path (cdr load-path)))
- (unless (file-exists-p (car module-load-path))
- (setq module-load-path (cdr module-load-path))))
+ (list (expand-file-name "modules" build-root)
+ (expand-file-name "modules" build-tree-root)
+ (expand-file-name "modules" source-tree-root)))
+ (unless (file-exists-p (car load-path))
+ (setq load-path (cdr load-path)))
+ (unless (file-exists-p (car module-load-path))
+ (setq module-load-path (cdr module-load-path))))
;; message not defined yet ...
(external-debugging-output (format "\nUsing load-path %s" load-path))
;; #### This code is duplicated in two other places.
(let ((temp-path (expand-file-name "." (car load-path))))
(setq load-path
- (nconc
- (mapcar
- #'(lambda (i) (concat i "/"))
- (directory-files temp-path t "^[^-.]"
- nil 'dirs-only))
- (cons (file-name-as-directory temp-path)
- load-path))))
+ (nconc
+ (mapcar
+ #'(lambda (i) (concat i "/"))
+ (directory-files temp-path t "^[^-.]"
+ nil 'dirs-only))
+ (cons (file-name-as-directory temp-path)
+ load-path))))
(setq load-warn-when-source-newer t ; Used to be set to nil at the end
load-warn-when-source-only t) ; Set to nil at the end
;;(print (format "guessed-roots: %S" (paths-find-emacs-roots invocation-directory invocation-name)))
nil)))
- (let ((f (locate-file "dumped-lisp.el" load-path)))
- (load f))
+ (let ((f (locate-file "dumped-lisp.el" load-path)))
+ (load f))
(let ((files preloaded-file-list)
file)
;; load-history) is normally done in lread.c after reading the
;; entirety of a file, something which never happens for loadup.el.
current-load-list nil)
-;; Make the path to this file look a little nicer:
+;; Make the path to this file look a little nicer:
(setcar (car load-history) (file-truename (caar load-history)))
(garbage-collect)
;; This is handled earlier in the build process.
;; (condition-case () (delete-file "sxemacs") (file-error nil))
(when-fboundp 'really-free
- (really-free))
+ (really-free))
(dump-emacs invf dmpf)
(kill-emacs))))
(append package-preloaded-file-list
preloaded-file-list
packages-hardcoded-lisp)
-
+
processed (cons "-d" processed)
processed (cons source-lisp processed)
;; Include loadup.el, which is never in preloaded-file-list:
(while preloaded-file-list
(setq arg0 (packages-add-suffix (car preloaded-file-list))
arg (locate-library arg0)
- absolute arg)
+ absolute arg)
(if (null arg)
(progn
(message "Error: dumped file %s does not exist" arg0)
;; Uncomment in case of difficulties
- ;(message "late-package-hierarchies: %S"
- ; late-package-hierarchies)
- ;(message "guessed-roots: %S" (paths-find-emacs-roots
- ; invocation-directory
- ; invocation-name
- ; #'paths-emacs-root-p))
- ;(message "guessed-data-roots: %S" (paths-find-emacs-roots
- ; invocation-directory
- ; invocation-name
- ; #'paths-emacs-data-root-p))
- )
+ ;(message "late-package-hierarchies: %S"
+ ; late-package-hierarchies)
+ ;(message "guessed-roots: %S" (paths-find-emacs-roots
+ ; invocation-directory
+ ; invocation-name
+ ; #'paths-emacs-root-p))
+ ;(message "guessed-data-roots: %S" (paths-find-emacs-roots
+ ; invocation-directory
+ ; invocation-name
+ ; #'paths-emacs-data-root-p))
+ )
(when (equal arg (expand-file-name arg0 source-lisp))
;; Use relative paths where possible, since this makes file lookup
;; in an installed XEmacs easier:
(if (null (member arg processed))
(progn
(if (and (null docfile-out-of-date)
- ;; We need to check the absolute path here:
+ ;; We need to check the absolute path here:
(file-newer-than-file-p absolute docfile))
(setq docfile-out-of-date t))
(setq processed (cons arg processed)))))
(if (should-use-dialog-box-p)
;; Make a list describing a dialog box.
(let (;; (object (capitalize (or (nth 0 help) "object")))
- ;; (objects (capitalize (or (nth 1 help) "objects")))
+ ;; (objects (capitalize (or (nth 1 help) "objects")))
;; (action (capitalize (or (nth 2 help) "act on")))
)
(setq map `(("%_Yes" . act) ("%_No" . skip)
LABEL-LENGTH characters of value."
(mapcar #'(lambda (x)
(if (<= (length x) label-length)
- (list x x)
- (list
- (concat "..." (substring x (- label-length))) x)))
+ (list x x)
+ (list
+ (concat "..." (substring x (- label-length))) x)))
(if (<= (length list) count)
list
(butlast list (- (length list) count)))))
menu
(let ((items
(submenu-generate-accelerator-spec
- (mapcar #'(lambda (label-value)
+ (mapcar #'(lambda (label-value)
(vector (first label-value)
(list 'grep (second label-value))))
(Menubar-items-truncate-history
- grep-history 10 50)))))
+ grep-history 10 50)))))
(append menu '("---") items))))
["%_Grep..." grep :active (fboundp 'grep)]
["%_Kill Grep" kill-compilation
(vector (first label-value)
(list 'compile (second label-value))))
(Menubar-items-truncate-history
- compile-history 10 50)))))
+ compile-history 10 50)))))
(append menu '("---") items))))
["%_Compile..." compile :active (fboundp 'compile)]
["%_Repeat Compilation" recompile :active (fboundp 'recompile)]
:active (and (boundp 'browse-url-browser-function)
(fboundp 'browse-url-w3)
(fboundp 'w3-fetch))]
- ["Emacs-%_W3 (gnuclient)"
- (customize-set-variable 'browse-url-browser-function 'browse-url-w3-gnudoit)
- :style radio
- :selected (and (boundp 'browse-url-browser-function)
- (eq browse-url-browser-function
- 'browse-url-w3-gnudoit))
+ ["Emacs-%_W3 (gnuclient)"
+ (customize-set-variable 'browse-url-browser-function 'browse-url-w3-gnudoit)
+ :style radio
+ :selected (and (boundp 'browse-url-browser-function)
+ (eq browse-url-browser-function
+ 'browse-url-w3-gnudoit))
:active (and (boundp 'browse-url-browser-function)
(fboundp 'browse-url-w3-gnudoit))]
["%_Netscape"
NEW-NAME is the string that the menu item will be printed as from now on."
(check-type new-name string)
(let* ((menubar current-menubar)
- (pair (find-menu-item menubar path))
- (item (car pair))
- (menu (cdr pair)))
+ (pair (find-menu-item menubar path))
+ (item (car pair))
+ (menu (cdr pair)))
(or item
- (signal 'error (list (if menu (gettext "No such menu item")
- (gettext "No such menu"))
- path)))
+ (signal 'error (list (if menu (gettext "No such menu item")
+ (gettext "No such menu"))
+ path)))
(if (and (consp item)
- (stringp (car item)))
- (setcar item new-name)
+ (stringp (car item)))
+ (setcar item new-name)
(aset item 0 new-name))
(set-menubar-dirty-flag)
item))
(defun enable-menu-item-1 (path toggle-p on-p)
(let (menu item)
(if (and (vectorp path) (> (length path) 2)) ; limited syntax checking...
- (setq item path)
+ (setq item path)
(let* ((menubar current-menubar)
- (pair (find-menu-item menubar path)))
- (setq item (car pair)
- menu (cdr pair))
- (or item
- (signal 'error (list (if menu
- "No such menu item"
- "No such menu")
- path)))
- (if (consp item)
- (error "%S is a menu, not a menu item" path))))
+ (pair (find-menu-item menubar path)))
+ (setq item (car pair)
+ menu (cdr pair))
+ (or item
+ (signal 'error (list (if menu
+ "No such menu item"
+ "No such menu")
+ path)))
+ (if (consp item)
+ (error "%S is a menu, not a menu item" path))))
(if (or (> (length item) 4)
- (and (symbolp (aref item 2))
- (= ?: (aref (symbol-name (aref item 2)) 0))))
- ;; plist-like syntax
- (let ((i 2)
- (keyword (if toggle-p :selected :active))
- (ok nil))
- (while (< i (length item))
- (cond ((eq (aref item i) keyword)
- (aset item (1+ i) on-p)
- (setq ok t)))
- (setq i (+ i 2)))
- (cond (ok nil)
- (toggle-p
- (signal 'error (list "not a toggle menu item" item)))
- (t
- ;; Need to copy the item to extend it, sigh...
- (let ((cons (memq item menu))
- (new-item (vconcat item (list keyword on-p))))
- (if cons
- (setcar cons (setq item new-item))
- (if menu
- (error "couldn't find %S on its parent?" item)
- (error "no %S slot to set: %S" keyword item)))))))
+ (and (symbolp (aref item 2))
+ (= ?: (aref (symbol-name (aref item 2)) 0))))
+ ;; plist-like syntax
+ (let ((i 2)
+ (keyword (if toggle-p :selected :active))
+ (ok nil))
+ (while (< i (length item))
+ (cond ((eq (aref item i) keyword)
+ (aset item (1+ i) on-p)
+ (setq ok t)))
+ (setq i (+ i 2)))
+ (cond (ok nil)
+ (toggle-p
+ (signal 'error (list "not a toggle menu item" item)))
+ (t
+ ;; Need to copy the item to extend it, sigh...
+ (let ((cons (memq item menu))
+ (new-item (vconcat item (list keyword on-p))))
+ (if cons
+ (setcar cons (setq item new-item))
+ (if menu
+ (error "couldn't find %S on its parent?" item)
+ (error "no %S slot to set: %S" keyword item)))))))
;; positional syntax
(if toggle-p
- (signal 'error (list "not a toggle menu item" item))
- (aset item 2 on-p)))
+ (signal 'error (list "not a toggle menu item" item))
+ (aset item 2 on-p)))
(set-menubar-dirty-flag)
item))
((event-matches-key-specifier-p new-event (quit-char))
(signal 'quit nil))
;; this function has been ordered to do essentially
- ;; X-specifc processing after this check.
- ((not (popup-up-p))
+ ;; X-specifc processing after this check.
+ ((not (popup-up-p))
(setq unread-command-events (cons new-event
unread-command-events))
(throw 'popup-done nil))
(defvar minibuffer-default nil
"Default value for minibuffer input.")
-
+
(defvar minibuffer-local-map
(let ((map (make-sparse-keymap 'minibuffer-local-map)))
map)
(defvar read-expression-map (let ((map (make-sparse-keymap
'read-expression-map)))
- (set-keymap-parents map
+ (set-keymap-parents map
(list minibuffer-local-map))
- (define-key map "\M-\t" 'lisp-complete-symbol)
- map)
+ (define-key map "\M-\t" 'lisp-complete-symbol)
+ map)
"Minibuffer keymap used for reading Lisp expressions.")
(defvar read-shell-command-map
(princ (cadr error-object) stream)))
(defun read-from-minibuffer (prompt &optional initial-contents
- keymap
- readp
- history
+ keymap
+ readp
+ history
abbrev-table
default)
"Read a string from the minibuffer, prompting with string PROMPT.
See also the variable `completion-highlight-first-word-only' for
control over completion display."
(if (and (not enable-recursive-minibuffers)
- (> (minibuffer-depth) 0)
- (eq (selected-window) (minibuffer-window)))
+ (> (minibuffer-depth) 0)
+ (eq (selected-window) (minibuffer-window)))
(error "Command attempted to use minibuffer while in minibuffer"))
(if (and minibuffer-max-depth
(> minibuffer-max-depth 0)
- (>= (minibuffer-depth) minibuffer-max-depth))
+ (>= (minibuffer-depth) minibuffer-max-depth))
(minibuffer-max-depth-exceeded))
;; catch this error before the poor user has typed something...
(if (noninteractive)
(progn
- ;; XEmacs in -batch mode calls minibuffer: print the prompt.
- (message "%s" (gettext prompt))
- ;;#### force-output
+ ;; XEmacs in -batch mode calls minibuffer: print the prompt.
+ (message "%s" (gettext prompt))
+ ;;#### force-output
- ;;#### Should this even be falling though to the code below?
- ;;#### How does this stuff work now, anyway?
- ))
+ ;;#### Should this even be falling though to the code below?
+ ;;#### How does this stuff work now, anyway?
+ ))
(let* ((dir default-directory)
- (owindow (selected-window))
+ (owindow (selected-window))
(oframe (selected-frame))
- (window (minibuffer-window))
- (buffer (if (eq (minibuffer-depth) 0)
- (window-buffer window)
+ (window (minibuffer-window))
+ (buffer (if (eq (minibuffer-depth) 0)
+ (window-buffer window)
(get-buffer-create (format " *Minibuf-%d"
(minibuffer-depth)))))
- (frame (window-frame window))
- (mconfig (if (eq frame (selected-frame))
- nil (current-window-configuration frame)))
- (oconfig (current-window-configuration))
+ (frame (window-frame window))
+ (mconfig (if (eq frame (selected-frame))
+ nil (current-window-configuration frame)))
+ (oconfig (current-window-configuration))
;; dynamic scope sucks sucks sucks sucks sucks sucks.
;; `M-x doctor' makes history a local variable, and thus
;; our binding above is buffer-local and doesn't apply
(_history_ history)
(minibuffer-default default))
(unwind-protect
- (progn
- (set-buffer (reset-buffer buffer))
- (setq default-directory dir)
- (make-local-variable 'print-escape-newlines)
- (setq print-escape-newlines t)
+ (progn
+ (set-buffer (reset-buffer buffer))
+ (setq default-directory dir)
+ (make-local-variable 'print-escape-newlines)
+ (setq print-escape-newlines t)
(make-local-variable 'current-minibuffer-contents)
(make-local-variable 'current-minibuffer-point)
(make-local-variable 'initial-minibuffer-history-position)
(make-local-variable 'mouse-track-click-hook)
(add-hook 'mouse-track-click-hook
'minibuffer-smart-maybe-select-highlighted-completion))
- (set-window-buffer window buffer)
- (select-window window)
- (set-window-hscroll window 0)
- (buffer-enable-undo buffer)
- (message nil)
- (if initial-contents
- (if (consp initial-contents)
- (progn
- (insert (car initial-contents))
- (goto-char (1+ (cdr initial-contents)))
+ (set-window-buffer window buffer)
+ (select-window window)
+ (set-window-hscroll window 0)
+ (buffer-enable-undo buffer)
+ (message nil)
+ (if initial-contents
+ (if (consp initial-contents)
+ (progn
+ (insert (car initial-contents))
+ (goto-char (1+ (cdr initial-contents)))
(setq current-minibuffer-contents (car initial-contents)
current-minibuffer-point (cdr initial-contents)))
(insert initial-contents)
(setq current-minibuffer-contents initial-contents
current-minibuffer-point (point))))
- (use-local-map (help-keymap-with-help-key
+ (use-local-map (help-keymap-with-help-key
(or keymap minibuffer-local-map)
minibuffer-help-form))
- (let ((mouse-grabbed-buffer
+ (let ((mouse-grabbed-buffer
(and minibuffer-smart-completion-tracking-behavior
(current-buffer)))
- (current-prefix-arg current-prefix-arg)
+ (current-prefix-arg current-prefix-arg)
;; (help-form minibuffer-help-form)
- (minibuffer-history-variable (cond ((not _history_)
- 'minibuffer-history)
- ((consp _history_)
- (car _history_))
- (t
- _history_)))
- (minibuffer-history-position (cond ((consp _history_)
- (cdr _history_))
- (t
- 0)))
- (minibuffer-scroll-window owindow))
+ (minibuffer-history-variable (cond ((not _history_)
+ 'minibuffer-history)
+ ((consp _history_)
+ (car _history_))
+ (t
+ _history_)))
+ (minibuffer-history-position (cond ((consp _history_)
+ (cdr _history_))
+ (t
+ 0)))
+ (minibuffer-scroll-window owindow))
(setq initial-minibuffer-history-position
minibuffer-history-position)
(if abbrev-table
(setq local-abbrev-table abbrev-table
abbrev-mode t))
;; This is now run from read-minibuffer-internal
- ;(if minibuffer-setup-hook
- ; (run-hooks 'minibuffer-setup-hook))
- ;(message nil)
-
- ;; Adjust the prompt
- (flet ((fmt-prompt-stack (p ps)
- (if (not ps)
- p
- (fmt-prompt-stack (concat "[" (car ps) "]" p) (cdr ps)))))
- (push prompt minibuffer-prompt-stack)
- (setq prompt (fmt-prompt-stack prompt (cdr minibuffer-prompt-stack))))
-
- (if (eq 't
- (catch 'exit
- (unwind-protect
- (if (> (recursion-depth) (minibuffer-depth))
- (let ((standard-output t)
- (standard-input t))
- (read-minibuffer-internal prompt))
- (read-minibuffer-internal prompt))
- (pop minibuffer-prompt-stack))))
-
- ;; Translate an "abort" (throw 'exit 't)
- ;; into a real quit
- (signal 'quit '())
- ;; return value
- (let* ((val (progn (set-buffer buffer)
- (if minibuffer-exit-hook
- (run-hooks 'minibuffer-exit-hook))
- (if (and (eq (char-after (point-min)) nil)
+ ;(if minibuffer-setup-hook
+ ; (run-hooks 'minibuffer-setup-hook))
+ ;(message nil)
+
+ ;; Adjust the prompt
+ (flet ((fmt-prompt-stack (p ps)
+ (if (not ps)
+ p
+ (fmt-prompt-stack (concat "[" (car ps) "]" p) (cdr ps)))))
+ (push prompt minibuffer-prompt-stack)
+ (setq prompt (fmt-prompt-stack prompt (cdr minibuffer-prompt-stack))))
+
+ (if (eq 't
+ (catch 'exit
+ (unwind-protect
+ (if (> (recursion-depth) (minibuffer-depth))
+ (let ((standard-output t)
+ (standard-input t))
+ (read-minibuffer-internal prompt))
+ (read-minibuffer-internal prompt))
+ (pop minibuffer-prompt-stack))))
+
+ ;; Translate an "abort" (throw 'exit 't)
+ ;; into a real quit
+ (signal 'quit '())
+ ;; return value
+ (let* ((val (progn (set-buffer buffer)
+ (if minibuffer-exit-hook
+ (run-hooks 'minibuffer-exit-hook))
+ (if (and (eq (char-after (point-min)) nil)
default)
default
(buffer-string))))
(histval (if (and default (string= val ""))
default
val))
- (err nil))
- (if readp
- (condition-case e
- (let ((v (read-from-string val)))
- (if (< (cdr v) (length val))
- (save-match-data
- (or (string-match "[ \t\n]*\\'" val (cdr v))
- (error "Trailing garbage following expression"))))
- (setq v (car v))
- ;; total total kludge
- (if (stringp v) (setq v (list 'quote v)))
- (setq val v))
- (end-of-file
+ (err nil))
+ (if readp
+ (condition-case e
+ (let ((v (read-from-string val)))
+ (if (< (cdr v) (length val))
+ (save-match-data
+ (or (string-match "[ \t\n]*\\'" val (cdr v))
+ (error "Trailing garbage following expression"))))
+ (setq v (car v))
+ ;; total total kludge
+ (if (stringp v) (setq v (list 'quote v)))
+ (setq val v))
+ (end-of-file
(setq err
'(input-error "End of input before end of expression")))
(error (setq err e))))
- ;; Add the value to the appropriate history list unless
- ;; it's already the most recent element, or it's only
- ;; two characters long.
- (if (and (symbolp minibuffer-history-variable)
- (boundp minibuffer-history-variable))
+ ;; Add the value to the appropriate history list unless
+ ;; it's already the most recent element, or it's only
+ ;; two characters long.
+ (if (and (symbolp minibuffer-history-variable)
+ (boundp minibuffer-history-variable))
(let ((list (symbol-value minibuffer-history-variable)))
(or (eq list t)
(null val)
(if minibuffer-history-uniquify
(cons histval (remove histval list))
(cons histval list))))))
- (if err (signal (car err) (cdr err)))
- val))))
+ (if err (signal (car err) (cdr err)))
+ val))))
;; stupid display code requires this for some reason
(set-buffer buffer)
(buffer-disable-undo buffer)
(goto-char (point-min))
(if (re-search-forward
(concat "^(setq minibuffer-max-depth "
- #r"\([0-9]+\|'?nil\|'?()\))"
- "\n")
+ #r"\([0-9]+\|'?nil\|'?()\))"
+ "\n")
nil t)
(delete-region (match-beginning 0 ) (match-end 0))
;; Must have been disabled by default.
;; gets set. In this case, we want that ^G to be interpreted
;; as a normal character, and act just like typeahead.
(if (and quit-flag (not unread-command-event))
- (setq unread-command-event (character-to-event (quit-char))
- quit-flag nil)))))
+ (setq unread-command-event (character-to-event (quit-char))
+ quit-flag nil)))))
;; Determines whether buffer-string is an exact completion
(defun exact-minibuffer-completion-p (buffer-string)
(cond ((not minibuffer-completion-table)
- ;; Empty alist
- nil)
- ((vectorp minibuffer-completion-table)
- (let ((tem (intern-soft buffer-string
- minibuffer-completion-table)))
- (if (or tem
- (and (string-equal buffer-string "nil")
- ;; intern-soft loses for 'nil
- (catch 'found
- (mapatoms #'(lambda (s)
+ ;; Empty alist
+ nil)
+ ((vectorp minibuffer-completion-table)
+ (let ((tem (intern-soft buffer-string
+ minibuffer-completion-table)))
+ (if (or tem
+ (and (string-equal buffer-string "nil")
+ ;; intern-soft loses for 'nil
+ (catch 'found
+ (mapatoms #'(lambda (s)
(if (string-equal
(symbol-name s)
buffer-string)
(throw 'found t)))
minibuffer-completion-table)
- nil)))
- (if minibuffer-completion-predicate
- (funcall minibuffer-completion-predicate
- tem)
- t)
- nil)))
- ((and (consp minibuffer-completion-table)
- ;;#### Emacs-Lisp truly sucks!
- ;; lambda, autoload, etc
- (not (symbolp (car minibuffer-completion-table))))
- (if (not completion-ignore-case)
- (assoc buffer-string minibuffer-completion-table)
- (let ((s (upcase buffer-string))
- (tail minibuffer-completion-table)
- tem)
- (while tail
- (setq tem (car (car tail)))
- (if (or (equal tem buffer-string)
- (equal tem s)
- (if tem (equal (upcase tem) s)))
- (setq s 'win
- tail nil) ;exit
- (setq tail (cdr tail))))
- (eq s 'win))))
- (t
- (funcall minibuffer-completion-table
- buffer-string
- minibuffer-completion-predicate
- 'lambda)))
+ nil)))
+ (if minibuffer-completion-predicate
+ (funcall minibuffer-completion-predicate
+ tem)
+ t)
+ nil)))
+ ((and (consp minibuffer-completion-table)
+ ;;#### Emacs-Lisp truly sucks!
+ ;; lambda, autoload, etc
+ (not (symbolp (car minibuffer-completion-table))))
+ (if (not completion-ignore-case)
+ (assoc buffer-string minibuffer-completion-table)
+ (let ((s (upcase buffer-string))
+ (tail minibuffer-completion-table)
+ tem)
+ (while tail
+ (setq tem (car (car tail)))
+ (if (or (equal tem buffer-string)
+ (equal tem s)
+ (if tem (equal (upcase tem) s)))
+ (setq s 'win
+ tail nil) ;exit
+ (setq tail (cdr tail))))
+ (eq s 'win))))
+ (t
+ (funcall minibuffer-completion-table
+ buffer-string
+ minibuffer-completion-predicate
+ 'lambda)))
)
;; 0 'none no possible completion
;; 6 'uncompleted no completion happened
(defun minibuffer-do-completion-1 (buffer-string completion)
(cond ((not completion)
- 'none)
- ((eq completion t)
- ;; exact and unique match
- 'unique)
- (t
- ;; It did find a match. Do we match some possibility exactly now?
- (let ((completedp (not (string-equal completion buffer-string))))
- (if completedp
- (progn
- ;; Some completion happened
- (erase-buffer)
- (insert completion)
- (setq buffer-string completion)))
- (if (exact-minibuffer-completion-p buffer-string)
- ;; An exact completion was possible
- (if completedp
+ 'none)
+ ((eq completion t)
+ ;; exact and unique match
+ 'unique)
+ (t
+ ;; It did find a match. Do we match some possibility exactly now?
+ (let ((completedp (not (string-equal completion buffer-string))))
+ (if completedp
+ (progn
+ ;; Some completion happened
+ (erase-buffer)
+ (insert completion)
+ (setq buffer-string completion)))
+ (if (exact-minibuffer-completion-p buffer-string)
+ ;; An exact completion was possible
+ (if completedp
;; Since no callers need to know the difference, don't bother
;; with this (potentially expensive) discrimination.
;; (if (eq (try-completion completion
;; minibuffer-completion-predicate)
;; 't)
;; 'completed-exact-unique
- 'completed-exact
+ 'completed-exact
;; )
- 'exact)
- ;; Not an exact match
- (if completedp
- 'completed
- 'uncompleted))))))
+ 'exact)
+ ;; Not an exact match
+ (if completedp
+ 'completed
+ 'uncompleted))))))
(defun minibuffer-do-completion (buffer-string)
(let* ((completion (try-completion buffer-string
- minibuffer-completion-table
- minibuffer-completion-predicate))
- (status (minibuffer-do-completion-1 buffer-string completion))
- (last last-exact-completion))
+ minibuffer-completion-table
+ minibuffer-completion-predicate))
+ (status (minibuffer-do-completion-1 buffer-string completion))
+ (last last-exact-completion))
(setq last-exact-completion nil)
(cond ((eq status 'none)
- ;; No completions
- (ding nil 'no-completion)
- (temp-minibuffer-message " [No match]"))
- ((eq status 'unique)
- )
- (t
- ;; It did find a match. Do we match some possibility exactly now?
- (if (not (string-equal completion buffer-string))
- (progn
- ;; Some completion happened
- (erase-buffer)
- (insert completion)
- (setq buffer-string completion)))
- (cond ((eq status 'exact)
- ;; If the last exact completion and this one were
- ;; the same, it means we've already given a
- ;; "Complete but not unique" message and that the
- ;; user's hit TAB again, so now we give help.
- (setq last-exact-completion completion)
- (if (equal buffer-string last)
- (minibuffer-completion-help)))
- ((eq status 'uncompleted)
- (if completion-auto-help
- (minibuffer-completion-help)
- (temp-minibuffer-message " [Next char not unique]")))
- (t
- nil))))
+ ;; No completions
+ (ding nil 'no-completion)
+ (temp-minibuffer-message " [No match]"))
+ ((eq status 'unique)
+ )
+ (t
+ ;; It did find a match. Do we match some possibility exactly now?
+ (if (not (string-equal completion buffer-string))
+ (progn
+ ;; Some completion happened
+ (erase-buffer)
+ (insert completion)
+ (setq buffer-string completion)))
+ (cond ((eq status 'exact)
+ ;; If the last exact completion and this one were
+ ;; the same, it means we've already given a
+ ;; "Complete but not unique" message and that the
+ ;; user's hit TAB again, so now we give help.
+ (setq last-exact-completion completion)
+ (if (equal buffer-string last)
+ (minibuffer-completion-help)))
+ ((eq status 'uncompleted)
+ (if completion-auto-help
+ (minibuffer-completion-help)
+ (temp-minibuffer-message " [Next char not unique]")))
+ (t
+ nil))))
status))
\f
;;;; completing-read
(defun completing-read (prompt table
- &optional predicate require-match
- initial-contents history default)
+ &optional predicate require-match
+ initial-contents history default)
"Read a string in the minibuffer, with completion.
PROMPT is a string to prompt with; normally it ends in a colon and a space.
Completion ignores case if the ambient value of
`completion-ignore-case' is non-nil."
(let ((minibuffer-completion-table table)
- (minibuffer-completion-predicate predicate)
- (minibuffer-completion-confirm (if (eq require-match 't) nil t))
- (last-exact-completion nil)
+ (minibuffer-completion-predicate predicate)
+ (minibuffer-completion-confirm (if (eq require-match 't) nil t))
+ (last-exact-completion nil)
ret)
(setq ret (read-from-minibuffer prompt
initial-contents
(setq minibuffer-scroll-window nil))
(let ((window minibuffer-scroll-window))
(if (and window (windowp window) (window-buffer window)
- (buffer-name (window-buffer window)))
+ (buffer-name (window-buffer window)))
;; If there's a fresh completion window with a live buffer
;; and this command is repeated, scroll that window.
(let ((obuf (current-buffer)))
- (unwind-protect
+ (unwind-protect
(progn
(set-buffer (window-buffer window))
(if (pos-visible-in-window-p (point-max) window)
;; Else scroll down one frame.
(scroll-other-window)))
(set-buffer obuf))
- nil)
+ nil)
(let ((status (minibuffer-do-completion (buffer-string))))
(if (eq status 'none)
nil
;; Short-cut -- don't call minibuffer-do-completion if we already
;; have an (possibly nonunique) exact completion.
(if (exact-minibuffer-completion-p buffer-string)
- (throw 'exit nil))
+ (throw 'exit nil))
(let ((status (minibuffer-do-completion buffer-string)))
(if (or (eq status 'unique)
- (eq status 'exact)
- (if (or (eq status 'completed-exact)
- (eq status 'completed-exact-unique))
- (if minibuffer-completion-confirm
- (progn (temp-minibuffer-message " [Confirm]")
- nil)
- t)))
- (throw 'exit nil)))))
+ (eq status 'exact)
+ (if (or (eq status 'completed-exact)
+ (eq status 'completed-exact-unique))
+ (if minibuffer-completion-confirm
+ (progn (temp-minibuffer-message " [Confirm]")
+ nil)
+ t)))
+ (throw 'exit nil)))))
(defun self-insert-and-exit ()
(throw 'exit nil))
(let ((buffer-string (buffer-string)))
(if (exact-minibuffer-completion-p buffer-string)
- (throw 'exit nil))
+ (throw 'exit nil))
(let ((completion (if (not minibuffer-completion-table)
- t
- (try-completion buffer-string
- minibuffer-completion-table
- minibuffer-completion-predicate))))
+ t
+ (try-completion buffer-string
+ minibuffer-completion-table
+ minibuffer-completion-predicate))))
(if (or (eq completion 't)
- ;; Crockishly allow user to specify null string
- (string-equal buffer-string ""))
- (throw 'exit nil))
+ ;; Crockishly allow user to specify null string
+ (string-equal buffer-string ""))
+ (throw 'exit nil))
(if completion ;; rewritten for I18N3 snarfing
(temp-minibuffer-message " [incomplete; confirm]")
(temp-minibuffer-message " [no completions; confirm]"))
(prog1
(next-command-event)
(setq quit-flag nil)))))
- (cond ((equal event last-command-event)
- (throw 'exit nil))
- ((equal (quit-char) (event-to-character event))
- ;; Minibuffer abort.
- (throw 'exit t)))
- (dispatch-event event)))))
+ (cond ((equal event last-command-event)
+ (throw 'exit nil))
+ ((equal (quit-char) (event-to-character event))
+ ;; Minibuffer abort.
+ (throw 'exit t)))
+ (dispatch-event event)))))
\f
;;;; minibuffer-complete-word
Return nil if there is no valid completion, else t."
(interactive)
(let* ((buffer-string (buffer-string))
- (completion (try-completion buffer-string
- minibuffer-completion-table
- minibuffer-completion-predicate))
- (status (minibuffer-do-completion-1 buffer-string completion)))
+ (completion (try-completion buffer-string
+ minibuffer-completion-table
+ minibuffer-completion-predicate))
+ (status (minibuffer-do-completion-1 buffer-string completion)))
(cond ((eq status 'none)
- (ding nil 'no-completion)
- (temp-minibuffer-message " [No match]")
- nil)
- ((eq status 'unique)
- ;; New message, only in this new Lisp code
- (temp-minibuffer-message " [Sole completion]")
- t)
- (t
- (cond ((or (eq status 'uncompleted)
- (eq status 'exact))
- (let ((foo #'(lambda (s)
+ (ding nil 'no-completion)
+ (temp-minibuffer-message " [No match]")
+ nil)
+ ((eq status 'unique)
+ ;; New message, only in this new Lisp code
+ (temp-minibuffer-message " [Sole completion]")
+ t)
+ (t
+ (cond ((or (eq status 'uncompleted)
+ (eq status 'exact))
+ (let ((foo #'(lambda (s)
(condition-case nil
(if (try-completion
(concat buffer-string s)
(goto-char (point-max))
(insert s)
t)
- nil)
- (error nil))))
- (char last-command-char))
- ;; Try to complete by adding a word-delimiter
- (or (and (characterp char) (> char 0)
- (funcall foo (char-to-string char)))
- (and (not (eq char ?\ ))
- (funcall foo " "))
- (and (not (eq char ?\-))
- (funcall foo "-"))
- (progn
- (if completion-auto-help
- (minibuffer-completion-help)
- ;; New message, only in this new Lisp code
+ nil)
+ (error nil))))
+ (char last-command-char))
+ ;; Try to complete by adding a word-delimiter
+ (or (and (characterp char) (> char 0)
+ (funcall foo (char-to-string char)))
+ (and (not (eq char ?\ ))
+ (funcall foo " "))
+ (and (not (eq char ?\-))
+ (funcall foo "-"))
+ (progn
+ (if completion-auto-help
+ (minibuffer-completion-help)
+ ;; New message, only in this new Lisp code
;; rewritten for I18N3 snarfing
(if (eq status 'exact)
(temp-minibuffer-message
" [Complete, but not unique]")
(temp-minibuffer-message " [Ambiguous]")))
- nil))))
- (t
- (erase-buffer)
- (insert completion)
- ;; First word-break in stuff found by completion
- (goto-char (point-min))
- (let ((len (length buffer-string))
- n)
- (if (and (< len (length completion))
- (catch 'match
- (setq n 0)
- (while (< n len)
- (if (char-equal
- (upcase (aref buffer-string n))
- (upcase (aref completion n)))
- (setq n (1+ n))
- (throw 'match nil)))
- t)
- (progn
- (goto-char (point-min))
- (forward-char len)
- (re-search-forward "\\W" nil t)))
- (delete-region (point) (point-max))
- (goto-char (point-max))))
- t))))))
+ nil))))
+ (t
+ (erase-buffer)
+ (insert completion)
+ ;; First word-break in stuff found by completion
+ (goto-char (point-min))
+ (let ((len (length buffer-string))
+ n)
+ (if (and (< len (length completion))
+ (catch 'match
+ (setq n 0)
+ (while (< n len)
+ (if (char-equal
+ (upcase (aref buffer-string n))
+ (upcase (aref completion n)))
+ (setq n (1+ n))
+ (throw 'match nil)))
+ t)
+ (progn
+ (goto-char (point-min))
+ (forward-char len)
+ (re-search-forward "\\W" nil t)))
+ (delete-region (point) (point-max))
+ (goto-char (point-max))))
+ t))))))
\f
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let ((kludge-string (concat (buffer-string) string)))
(if (or (and (fboundp 'ange-ftp-ftp-path)
(declare-fboundp (ange-ftp-ftp-path kludge-string)))
- (and (fboundp 'efs-ftp-path)
+ (and (fboundp 'efs-ftp-path)
(declare-fboundp (efs-ftp-path kludge-string))))
;; #### evil evil evil, but more so.
string
(if minibuffer-history-sexp-flag
(let ((print-level nil))
(prin1-to-string (nth (1- pos) history)))
- (nth (1- pos) history)))
+ (nth (1- pos) history)))
(setq n (+ n (if (< n 0) 1 -1)))))
(setq minibuffer-history-position pos)
(setq current-minibuffer-contents (buffer-string)
(insert (if minibuffer-history-sexp-flag
(let ((print-level nil))
(prin1-to-string elt))
- elt)))
+ elt)))
(goto-char (point-min)))
(if (or (eq (car (car command-history)) 'previous-matching-history-element)
(eq (car (car command-history)) 'next-matching-history-element))
enters an empty line. If optional third arg REQUIRE-MATCH is non-nil,
only existing buffer names are allowed."
(let ((prompt (if default
- (format "%s(default %s) "
- (gettext prompt) (if (bufferp default)
+ (format "%s(default %s) "
+ (gettext prompt) (if (bufferp default)
(buffer-name default)
default))
- prompt))
- (alist (mapcar #'(lambda (b) (cons (buffer-name b) b))
- (buffer-list)))
- result)
+ prompt))
+ (alist (mapcar #'(lambda (b) (cons (buffer-name b) b))
+ (buffer-list)))
+ result)
(while (progn
- (setq result (completing-read prompt alist nil require-match
- nil 'buffer-history
+ (setq result (completing-read prompt alist nil require-match
+ nil 'buffer-history
(if (bufferp default)
(buffer-name default)
default)))
- (cond ((not (equal result ""))
- nil)
- ((not require-match)
- (setq result default)
- nil)
- ((not default)
- t)
- ((not (get-buffer default))
- t)
- (t
- (setq result default)
- nil))))
+ (cond ((not (equal result ""))
+ nil)
+ ((not require-match)
+ (setq result default)
+ nil)
+ ((not default)
+ t)
+ ((not (get-buffer default))
+ t)
+ (t
+ (setq result default)
+ nil))))
(if (bufferp result)
- (buffer-name result)
+ (buffer-name result)
result)))
(defun read-number (prompt &optional integers-only default-value)
;; Quote "$" as "$$" to get it past substitute-in-file-name
(defun un-substitute-in-file-name (string)
(let ((regexp "\\$")
- (olen (length string))
- new
- n o ch)
+ (olen (length string))
+ new
+ n o ch)
(if (not (string-match regexp string))
string
(setq n 1)
;; improve the performance of this operation.
(defun minibuf-directory-files (dir &optional match-regexp files-only)
(let ((want-file (or (eq files-only nil) (eq files-only t)))
- (want-dirs (or (eq files-only nil) (not (eq files-only t)))))
+ (want-dirs (or (eq files-only nil) (not (eq files-only t)))))
(delete nil
- (mapcar (function (lambda (f)
- (if (file-directory-p (expand-file-name f dir))
- (and want-dirs (file-name-as-directory f))
- (and want-file f))))
- (delete "." (directory-files dir nil match-regexp))))))
+ (mapcar (function (lambda (f)
+ (if (file-directory-p (expand-file-name f dir))
+ (and want-dirs (file-name-as-directory f))
+ (and want-file f))))
+ (delete "." (directory-files dir nil match-regexp))))))
(defun read-file-name-2 (history prompt dir default
(setq dir (abbreviate-file-name dir t))
(let* ((insert (cond ((and (not insert-default-directory)
(not initial-contents))
- "")
- (initial-contents
- (cons (un-substitute-in-file-name
+ "")
+ (initial-contents
+ (cons (un-substitute-in-file-name
(concat dir initial-contents))
- (length dir)))
- (t
- (un-substitute-in-file-name dir))))
- (val
- ;; Hateful, broken, case-sensitive un*x
+ (length dir)))
+ (t
+ (un-substitute-in-file-name dir))))
+ (val
+ ;; Hateful, broken, case-sensitive un*x
;;; (completing-read prompt
;;; completer
;;; dir
;;; (set hist (cons e (cdr (symbol-value hist))))))))
(cond ((not val)
- (error "No file name specified"))
- ((and default
- (equal val (if (consp insert) (car insert) insert)))
- default)
- (t
- (substitute-in-file-name val)))))
+ (error "No file name specified"))
+ ((and default
+ (equal val (if (consp insert) (car insert) insert)))
+ default)
+ (t
+ (substitute-in-file-name val)))))
;; #### this function should use minibuffer-completion-table
;; or something. But that is sloooooow.
(reset-buffer completion-buf)
(let ((standard-output completion-buf))
(display-completion-list
- (minibuf-directory-files full nil (if dir-p 'directory))
+ (minibuf-directory-files full nil (if dir-p 'directory))
:user-data dir-p
:reference-buffer minibuf
:activate-callback 'read-file-name-activate-callback)
initial-contents completer)))
(defun read-file-name (prompt
- &optional dir default must-match initial-contents
+ &optional dir default must-match initial-contents
history)
"Read file name, prompting with PROMPT and completing in directory DIR.
This will prompt with a dialog box if appropriate, according to
Sixth arg HISTORY specifies the history list to use. Default is
`file-name-history'.
DIR defaults to current buffer's directory default."
- (read-file-name-1
+ (read-file-name-1
'file (or history 'file-name-history)
prompt dir (or default
(and initial-contents
'read-file-name-internal))
(defun read-directory-name (prompt
- &optional dir default must-match initial-contents
+ &optional dir default must-match initial-contents
history)
"Read directory name, prompting with PROMPT and completing in directory DIR.
This will prompt with a dialog box if appropriate, according to
string))
;; Not doing environment-variable completion hack
(let* ((orig (if (equal string "") nil string))
- (sstring (if orig (substitute-in-file-name string) string))
- (specdir (if orig (file-name-directory sstring) nil))
- (name (if orig (file-name-nondirectory sstring) string))
- (direct (if specdir (expand-file-name specdir dir) dir)))
- ;; ~username completion
- (if (and (fboundp 'user-name-completion-1)
- (string-match "^[~]" name))
- (let ((user (substring name 1)))
- (cond ((eq action 'lambda)
- (file-directory-p name))
- ((eq action 't)
- ;; all completions
- (mapcar #'(lambda (p) (concat "~" p))
- (user-name-all-completions user)))
- (t;; 'nil
- ;; complete
- (let* ((val+uniq (user-name-completion-1 user))
- (val (car val+uniq))
- (uniq (cdr val+uniq)))
- (cond ((stringp val)
- (if uniq
- (file-name-as-directory (concat "~" val))
- (concat "~" val)))
- ((eq val t)
- (file-name-as-directory name))
- (t nil))))))
- (funcall completer
- action
- orig
- sstring
- specdir
- direct
- name)))
+ (sstring (if orig (substitute-in-file-name string) string))
+ (specdir (if orig (file-name-directory sstring) nil))
+ (name (if orig (file-name-nondirectory sstring) string))
+ (direct (if specdir (expand-file-name specdir dir) dir)))
+ ;; ~username completion
+ (if (and (fboundp 'user-name-completion-1)
+ (string-match "^[~]" name))
+ (let ((user (substring name 1)))
+ (cond ((eq action 'lambda)
+ (file-directory-p name))
+ ((eq action 't)
+ ;; all completions
+ (mapcar #'(lambda (p) (concat "~" p))
+ (user-name-all-completions user)))
+ (t;; 'nil
+ ;; complete
+ (let* ((val+uniq (user-name-completion-1 user))
+ (val (car val+uniq))
+ (uniq (cdr val+uniq)))
+ (cond ((stringp val)
+ (if uniq
+ (file-name-as-directory (concat "~" val))
+ (concat "~" val)))
+ ((eq val t)
+ (file-name-as-directory name))
+ (t nil))))))
+ (funcall completer
+ action
+ orig
+ sstring
+ specdir
+ direct
+ name)))
;; An odd number of trailing $'s
(let* ((start (match-beginning 3))
- (env (substring string
- (cond ((= start (length string))
- ;; "...$"
- start)
- ((= (aref string start) ?{)
- ;; "...${..."
- (1+ start))
- (t
- start))))
- (head (substring string 0 (1- start)))
- (alist #'(lambda ()
- (mapcar #'(lambda (x)
- (cons (substring x 0 (string-match "=" x))
- nil))
- process-environment))))
+ (env (substring string
+ (cond ((= start (length string))
+ ;; "...$"
+ start)
+ ((= (aref string start) ?{)
+ ;; "...${..."
+ (1+ start))
+ (t
+ start))))
+ (head (substring string 0 (1- start)))
+ (alist #'(lambda ()
+ (mapcar #'(lambda (x)
+ (cons (substring x 0 (string-match "=" x))
+ nil))
+ process-environment))))
(cond ((eq action 'lambda)
- nil)
- ((eq action 't)
- ;; all completions
- (mapcar #'(lambda (p)
+ nil)
+ ((eq action 't)
+ ;; all completions
+ (mapcar #'(lambda (p)
(if (and (> (length p) 0)
;;#### Unix-specific
;;#### -- need absolute-pathname-p
(/= (aref p 0) ?/))
(concat "$" p)
- (concat head "$" p)))
- (all-completions env (funcall alist))))
- (t ;; nil
- ;; complete
- (let* ((e (funcall alist))
- (val (try-completion env e)))
- (cond ((stringp val)
- (if (string-match "[^A-Za-z0-9_]" val)
- (concat head
- "${" val
- ;; completed uniquely?
- (if (eq (try-completion val e) 't)
- "}" ""))
- (concat head "$" val)))
- ((eql val 't)
- (concat head
- (un-substitute-in-file-name (getenv env))))
- (t nil))))))))
+ (concat head "$" p)))
+ (all-completions env (funcall alist))))
+ (t ;; nil
+ ;; complete
+ (let* ((e (funcall alist))
+ (val (try-completion env e)))
+ (cond ((stringp val)
+ (if (string-match "[^A-Za-z0-9_]" val)
+ (concat head
+ "${" val
+ ;; completed uniquely?
+ (if (eq (try-completion val e) 't)
+ "}" ""))
+ (concat head "$" val)))
+ ((eql val 't)
+ (concat head
+ (un-substitute-in-file-name (getenv env))))
+ (t nil))))))))
(defun read-file-name-internal (string dir action)
string dir action
#'(lambda (action orig string specdir dir name)
(cond ((eq action 'lambda)
- (if (not orig)
- nil
- (let ((sstring (condition-case nil
- (expand-file-name string)
- (error nil))))
- (if (not sstring)
- ;; Some pathname syntax error in string
- nil
- (file-exists-p sstring)))))
- ((eq action 't)
- ;; all completions
- (mapcar #'un-substitute-in-file-name
- (if (string= name "")
- (delete "./" (file-name-all-completions "" dir))
- (file-name-all-completions name dir))))
- (t;; nil
- ;; complete
- (let* ((d (or dir default-directory))
+ (if (not orig)
+ nil
+ (let ((sstring (condition-case nil
+ (expand-file-name string)
+ (error nil))))
+ (if (not sstring)
+ ;; Some pathname syntax error in string
+ nil
+ (file-exists-p sstring)))))
+ ((eq action 't)
+ ;; all completions
+ (mapcar #'un-substitute-in-file-name
+ (if (string= name "")
+ (delete "./" (file-name-all-completions "" dir))
+ (file-name-all-completions name dir))))
+ (t;; nil
+ ;; complete
+ (let* ((d (or dir default-directory))
(val (file-name-completion name d)))
- (if (and (eq val 't)
- (not (null completion-ignored-extensions)))
- ;;#### (file-name-completion "foo") returns 't
- ;; when both "foo" and "foo~" exist and the latter
- ;; is "pruned" by completion-ignored-extensions.
- ;; I think this is a bug in file-name-completion.
- (setq val (let ((completion-ignored-extensions '()))
- (file-name-completion name d))))
- (if (stringp val)
- (un-substitute-in-file-name (if specdir
- (concat specdir val)
- val))
- (let ((tem (un-substitute-in-file-name string)))
- (if (not (equal tem orig))
- ;; substitute-in-file-name did something
- tem
- val)))))))))
+ (if (and (eq val 't)
+ (not (null completion-ignored-extensions)))
+ ;;#### (file-name-completion "foo") returns 't
+ ;; when both "foo" and "foo~" exist and the latter
+ ;; is "pruned" by completion-ignored-extensions.
+ ;; I think this is a bug in file-name-completion.
+ (setq val (let ((completion-ignored-extensions '()))
+ (file-name-completion name d))))
+ (if (stringp val)
+ (un-substitute-in-file-name (if specdir
+ (concat specdir val)
+ val))
+ (let ((tem (un-substitute-in-file-name string)))
+ (if (not (equal tem orig))
+ ;; substitute-in-file-name did something
+ tem
+ val)))))))))
(defun read-directory-name-internal (string dir action)
(read-file-name-internal-1
(mapcar fn
;; Wretched unix
(delete "." l))))))
- (cond ((eq action 'lambda)
- ;; complete?
- (if (not orig)
- nil
+ (cond ((eq action 'lambda)
+ ;; complete?
+ (if (not orig)
+ nil
(file-directory-p string)))
- ((eq action 't)
- ;; all completions
- (funcall dirs #'(lambda (n)
+ ((eq action 't)
+ ;; all completions
+ (funcall dirs #'(lambda (n)
(un-substitute-in-file-name
(file-name-as-directory n)))))
- (t
- ;; complete
- (let ((val (try-completion
- name
- (funcall dirs
- #'(lambda (n)
+ (t
+ ;; complete
+ (let ((val (try-completion
+ name
+ (funcall dirs
+ #'(lambda (n)
(list (file-name-as-directory
n)))))))
- (if (stringp val)
- (un-substitute-in-file-name (if specdir
- (concat specdir val)
+ (if (stringp val)
+ (un-substitute-in-file-name (if specdir
+ (concat specdir val)
val))
(let ((tem (un-substitute-in-file-name string)))
(if (not (equal tem orig))
(when (featurep 'scrollbar)
(set-specifier scrollbar-width 0 (current-buffer)))
(setq truncate-lines t))))
-
+
(set-buffer filebuf)
(add-local-hook 'completion-setup-hook rfcshookfun)
(when file-p
Prompting with string PROMPT.
If the user enters null input, return second argument DEFAULT-CODING-SYSTEM.
DEFAULT-CODING-SYSTEM can be a string, symbol, or coding-system object."
- (intern (completing-read prompt obarray 'find-coding-system t nil nil
+ (intern (completing-read prompt obarray 'find-coding-system t nil nil
(cond ((symbolp default-coding-system)
(symbol-name default-coding-system))
((coding-system-p default-coding-system)
(defvar mode-motion-hook nil
"Function or functions which are called whenever the mouse moves.
Each function must take a single argument of the motion event.
-You should normally use this rather than `mouse-motion-handler', which
+You should normally use this rather than `mouse-motion-handler', which
does some additional window-system-dependent things. This hook is local
to every buffer, and should normally be set up by major-modes which want
to use special highlighting. Every time the mouse moves over a window,
'global-mode-string
" %[("
(cons modeline-minor-mode-extent
- (list "" 'mode-name 'minor-mode-alist))
+ (list "" 'mode-name 'minor-mode-alist))
(cons modeline-narrowed-extent "%n")
'modeline-process
")%]----"
(interactive "P")
;; we fallback to the clipboard if the current selection is not existent
(let ((text (or (get-selection-no-error 'PRIMARY 'UTF8_STRING)
- (get-selection-no-error 'PRIMARY 'STRING)
- (and check-cutbuffer-p (get-cutbuffer))
- (get-selection-no-error 'CLIPBOARD 'UTF8_STRING)
- (get-selection-no-error 'CLIPBOARD 'STRING)
- (error "no selection: PRIMARY or CLIPBOARD")
- )))
+ (get-selection-no-error 'PRIMARY 'STRING)
+ (and check-cutbuffer-p (get-cutbuffer))
+ (get-selection-no-error 'CLIPBOARD 'UTF8_STRING)
+ (get-selection-no-error 'CLIPBOARD 'STRING)
+ (error "no selection: PRIMARY or CLIPBOARD")
+ )))
(cond (move-point-event
(mouse-set-point move-point-event)
(push-mark (point)))
(not (= start end)))
;; I guess cutbuffers should do something with rectangles too.
;; does anybody use them?
- (x-store-cutbuffer (buffer-substring start end)))))
+ (x-store-cutbuffer (buffer-substring start end)))))
(defun mouse-track-activate-rectangular-selection ()
(if (consp default-mouse-track-extent)
;;; ;;
;;; (if nil ; (eq default-mouse-track-type 'char)
;;; (let ((after-end-p (and (not (eobp))
-;;; (eolp)
+;;; (eolp)
;;; (> (point) (car result)))))
;;; (if after-end-p
;;; (progn
(glyph-extent (highlight-extent glyph-extent t))
(t (highlight-extent nil nil)))
(cond ((extentp help)
- (or inhibit-help-echo
- (eq help last-help-echo-object) ;save some time
+ (or inhibit-help-echo
+ (eq help last-help-echo-object) ;save some time
(eq (selected-window) (minibuffer-window))
- (let ((hprop (extent-property help 'help-echo)))
- (setq last-help-echo-object help)
- (or (stringp hprop)
- (setq hprop (funcall hprop help)))
- (and hprop (show-help-echo hprop)))))
+ (let ((hprop (extent-property help 'help-echo)))
+ (setq last-help-echo-object help)
+ (or (stringp hprop)
+ (setq hprop (funcall hprop help)))
+ (and hprop (show-help-echo hprop)))))
((and (featurep 'toolbar)
- (toolbar-button-p help)
- (toolbar-button-enabled-p help))
+ (toolbar-button-p help)
+ (toolbar-button-enabled-p help))
(or (not toolbar-help-enabled)
(eq help last-help-echo-object) ;save some time
(eq (selected-window) (minibuffer-window))
(or (stringp hstring)
(setq hstring (funcall hstring help)))
(and hstring (show-help-echo hstring)))))
- (last-help-echo-object
+ (last-help-echo-object
(clear-help-echo)))
(if mouse-grabbed-buffer (setq buffer mouse-grabbed-buffer))
(if (and buffer (symbol-value-in-buffer 'mode-motion-hook buffer nil))
(ccl-embed-data op)
(ccl-embed-data arg))
(ccl-check-register arg cmd)
- (ccl-embed-code (if read-flag 'read-jump-cond-expr-register
+ (ccl-embed-code (if read-flag 'read-jump-cond-expr-register
'jump-cond-expr-register)
rrr 0)
(ccl-embed-data op)
(error "CCL: Invalid argument %s: %s" arg cmd)))
(ccl-embed-code 'read-jump rrr ccl-loop-head))
t)
-
+
;; Compile READ statement.
(defun ccl-compile-read (cmd)
(if (< (length cmd) 2)
add 1))
(setq arg (cdr arg)
len (+ len add)))
- (if mp
+ (if mp
(cons (- len) result)
result))))
(setq arg (append (list (nth 0 cmd) (nth 1 cmd) (nth 2 cmd))
(rrr (ash (logand code 255) -5))
(cc (ash code -8)))
(insert (format "%5d:[%s] " (1- ccl-current-ic) cmd))
- (funcall (get cmd 'ccl-dump-function) rrr cc)))
+ (funcall (get cmd 'ccl-dump-function) rrr cc)))
(defun ccl-dump-set-register (rrr cc)
(insert (format "r%d = r%d\n" rrr cc)))
(insert (format "map-single r%d r%d map(%S)\n" RRR rrr id))))
\f
-;; CCL emulation staffs
+;; CCL emulation staffs
;; Not yet implemented.
\f
| (write integer)
;; Write the byte sequence of `string' as is to the output
;; buffer. It is encoded by binary coding system, thus,
- ;; by this operation, you cannot write multibyte string
- ;; as it is.
+ ;; by this operation, you cannot write multibyte string
+ ;; as it is.
| (write string)
;; Same as: (write string)
| string
;; (REG <8= ARG) is the same as:
;; ((REG <<= 8)
;; (REG |= ARG))
- | <8=
+ | <8=
;; (REG >8= ARG) is the same as:
;; ((r7 = (REG & 255))
(name plane final)
(make-charset
name (concat "CNS 11643 Plane " plane " (Chinese traditional)")
- `(registry
- ,(concat "CNS11643[.-]\\(.*[.-]\\)?" plane "$")
- dimension 2
- chars 94
- final ,final
- graphic 0))
+ `(registry
+ ,(concat "CNS11643[.-]\\(.*[.-]\\)?" plane "$")
+ dimension 2
+ chars 94
+ final ,final
+ graphic 0))
(modify-syntax-entry name "w")
(modify-category-entry name ?t)
))
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Chinese GB2312 (simplified)
+;;; Chinese GB2312 (simplified)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; (make-coding-system
(insert-buffer-substring buf from to))
(declare-fboundp (encode-hz-region 1 (point-max)))
nil))
-
+
(set-language-info-alist
"Chinese-GB" '((setup-function . setup-chinese-gb-environment-internal)
(charset chinese-gb2312 sisheng)
32 ?\e$(C"F\e(B 32 32 ?\e$B"#\e(B 32 ?\e$B"e\e(B ?\e$A!V\e(B ?\e$A!\\e(B ?\e$A!]\e(B ?\e,L \e(B 32 ?\e,A0\e(B ?\e,A2\e(B ?\e,A7\e(B ?\e,Aw\e(B
?\e$(G#D\e(B 32 32 ?\e,Lq\e(B 32 32 32 32 32 32 32 32 32 32 32 ?\e$(G#E\e(B
32 32 ?\e$(G#G\e(B ?\e,L!\e(B 32 32 32 32 32 32 32 32 ?\e$(G#F\e(B 32 32 ?\e,A)\e(B
- ?\e,Ln\e(B ?\e,LP\e(B ?\e,LQ\e(B ?\e,Lf\e(B ?\e,LT\e(B ?\e,LU\e(B ?\e,Ld\e(B ?\e,LS\e(B ?\e,Le\e(B ?\e,LX\e(B ?\e,LY\e(B ?\e,LZ\e(B ?\e,L[\e(B ?\e,L\\e(B ?\e,L]\e(B ?\e,L^\e(B
- ?\e,L_\e(B ?\e,Lo\e(B ?\e,L`\e(B ?\e,La\e(B ?\e,Lb\e(B ?\e,Lc\e(B ?\e,LV\e(B ?\e,LR\e(B ?\e,Ll\e(B ?\e,Lk\e(B ?\e,LW\e(B ?\e,Lh\e(B ?\e,Lm\e(B ?\e,Li\e(B ?\e,Lg\e(B ?\e,Lj\e(B
- ?\e,LN\e(B ?\e,L0\e(B ?\e,L1\e(B ?\e,LF\e(B ?\e,L4\e(B ?\e,L5\e(B ?\e,LD\e(B ?\e,L3\e(B ?\e,LE\e(B ?\e,L8\e(B ?\e,L9\e(B ?\e,L:\e(B ?\e,L;\e(B ?\e,L<\e(B ?\e,L=\e(B ?\e,L>\e(B
+ ?\e,Ln\e(B ?\e,LP\e(B ?\e,LQ\e(B ?\e,Lf\e(B ?\e,LT\e(B ?\e,LU\e(B ?\e,Ld\e(B ?\e,LS\e(B ?\e,Le\e(B ?\e,LX\e(B ?\e,LY\e(B ?\e,LZ\e(B ?\e,L[\e(B ?\e,L\\e(B ?\e,L]\e(B ?\e,L^\e(B
+ ?\e,L_\e(B ?\e,Lo\e(B ?\e,L`\e(B ?\e,La\e(B ?\e,Lb\e(B ?\e,Lc\e(B ?\e,LV\e(B ?\e,LR\e(B ?\e,Ll\e(B ?\e,Lk\e(B ?\e,LW\e(B ?\e,Lh\e(B ?\e,Lm\e(B ?\e,Li\e(B ?\e,Lg\e(B ?\e,Lj\e(B
+ ?\e,LN\e(B ?\e,L0\e(B ?\e,L1\e(B ?\e,LF\e(B ?\e,L4\e(B ?\e,L5\e(B ?\e,LD\e(B ?\e,L3\e(B ?\e,LE\e(B ?\e,L8\e(B ?\e,L9\e(B ?\e,L:\e(B ?\e,L;\e(B ?\e,L<\e(B ?\e,L=\e(B ?\e,L>\e(B
?\e,L?\e(B ?\e,LO\e(B ?\e,L@\e(B ?\e,LA\e(B ?\e,LB\e(B ?\e,LC\e(B ?\e,L6\e(B ?\e,L2\e(B ?\e,LL\e(B ?\e,LK\e(B ?\e,L7\e(B ?\e,LH\e(B ?\e,LM\e(B ?\e,LI\e(B ?\e,LG\e(B ?\e,LJ\e(B ]
"Cyrillic KOI8-R decoding table.")
(setq i (1+ i)))
table)
"Cyrillic ALTERNATIVNYJ encoding table.")
-
+
)
do (modify-category-entry `[japanese-jisx0208 ,row] ?C))
(loop for char in '(?\e$B!<\e(B ?\e$B!+\e(B ?\e$B!,\e(B)
do (modify-category-entry char ?K)
- (modify-category-entry char ?H))
+ (modify-category-entry char ?H))
(loop for char in '(?\e$B!3\e(B ?\e$B!4\e(B ?\e$B!5\e(B ?\e$B!6\e(B ?\e$B!7\e(B ?\e$B!8\e(B ?\e$B!9\e(B ?\e$B!:\e(B ?\e$B!;\e(B)
do (modify-category-entry char ?C))
(modify-category-entry 'japanese-jisx0212 ?C)
;; locally.
(defvar aletter (concat "\\(" ascii-char "\\|" kanji-char "\\)"))
-(defvar kanji-space-insertable (concat
+(defvar kanji-space-insertable (concat
"\e$B!"\e(B" aletter "\\|"
"\e$B!#\e(B" aletter "\\|"
aletter "\e$B!J\e(B" "\\|"
-;; kinsoku.el -- Kinsoku (line wrap) processing for XEmacs/Mule
+;; kinsoku.el -- Kinsoku (line wrap) processing for XEmacs/Mule -*- coding: iso-2022-7bit; -*-
;; Copyright (C) 1997 Free Software Foundation, Inc.
;; This file is part of Mule (MULtilingual Enhancement of XEmacs).
"EOL kinsoku for GB2312.")
(defvar kinsoku-big5-bol
(concat "\e$(0!"!#!$!%!&!'!(!)!*!+!,!-!.!/!0!1!2\e(B"
- "\e$(0!3!4!5!6!7!8!9!:!;!<!=!?!A!C!E!G!I!K\e(B"
- "\e$(0!M!O!Q\e(B \e$(0!S!U!W!Y![!]!_!a!c!e!g!i!k!q\e(B"
- "\e$(0"#"$"%"&"'"(")"*"+","2"3"4"j"k"l"x%7\e(B")
+ "\e$(0!3!4!5!6!7!8!9!:!;!<!=!?!A!C!E!G!I!K\e(B"
+ "\e$(0!M!O!Q\e(B \e$(0!S!U!W!Y![!]!_!a!c!e!g!i!k!q\e(B"
+ "\e$(0"#"$"%"&"'"(")"*"+","2"3"4"j"k"l"x%7\e(B")
"BOL kinsoku for BIG5.")
(defvar kinsoku-big5-eol
(concat "\e$(0!>!@!B!D!F!H!J!L!N!P!R!T!V!X!Z!\!^!`!b\e(B"
- "\e$(0!d!f!h!j!k!q!p"i"j"k"n"x$u$v$w$x$y$z${\e(B"
- "\e$(0$|$}$~%!%"%#%$%%%&%'%(%)%*%+%:\e(B")
+ "\e$(0!d!f!h!j!k!q!p"i"j"k"n"x$u$v$w$x$y$z${\e(B"
+ "\e$(0$|$}$~%!%"%#%$%%%&%'%(%)%*%+%:\e(B")
"EOL kinsoku for BIG5.")
(define-category ?s "Kinsoku forbidden start of line characters")
(defun kinsoku-process-extend ()
"Move point forward to a permissable for line-breaking.
\e$B9T$r?-$P$7$F6XB'$K?($l$J$$E@$X0\F0$9$k!#\e(B"
- (let ((max-column (+ fill-column
+ (let ((max-column (+ fill-column
(if (and (numberp kinsoku-extend-limit)
(>= kinsoku-extend-limit 0))
kinsoku-extend-limit
(not (eolp))
(or (kinsoku-eol-p)
(kinsoku-bol-p)
- ;;; don't break in the middle of an English word
+ ;;; don't break in the middle of an English word
(and (char-in-category-p ch1 ?a)
(setq ch2 (char-before))
(char-in-category-p ch2 ?a)
;;; be buffer-local---strategy for dealing with this: check all $language.el
;;; files and also mule-base/$language-utils.el files for variables set;
;;; these should be made buffer local and some kind of a- or p-list of vars
-;;; to be set for a language environment created.
+;;; to be set for a language environment created.
(defvar word-across-newline "\\(\\cj\\|\\cc\\|\\ct\\)"
"Regular expression of such characters which can be a word across newline.")
(defun charsets-in-string (string)
"Return a list of the charsets in STRING."
(let ((i 0)
- (len (length string))
- prev-charset charset list)
+ (len (length string))
+ prev-charset charset list)
(while (< i len)
(setq charset (char-charset (aref string i)))
(if (not (eq prev-charset charset))
- (progn
- (setq prev-charset charset)
- (or (memq charset list)
- (setq list (cons charset list)))))
+ (progn
+ (setq prev-charset charset)
+ (or (memq charset list)
+ (setq list (cons charset list)))))
(setq i (1+ i)))
list))
(setq eol-type (cond ((or (eq eol-type 'unix)
(eq eol-type 'lf))
'eol-lf)
- ((or (eq eol-type 'dos)
+ ((or (eq eol-type 'dos)
(eq eol-type 'crlf))
'eol-crlf)
- ((or (eq eol-type 'mac)
+ ((or (eq eol-type 'mac)
(eq eol-type 'cr))
'eol-cr)
- (t eol-type))))
+ (t eol-type))))
(let ((orig-eol-type (coding-system-eol-type coding-system)))
(if (null orig-eol-type)
- (if (not eol-type)
- coding-system
- (coding-system-property coding-system eol-type))
+ (if (not eol-type)
+ coding-system
+ (coding-system-property coding-system eol-type))
(let ((base (coding-system-base coding-system)))
- (if (not eol-type)
- base
- (if (eq eol-type orig-eol-type)
- coding-system
- (setq orig-eol-type (coding-system-eol-type base))
- (if (null orig-eol-type)
- (coding-system-property base eol-type))))))))
+ (if (not eol-type)
+ base
+ (if (eq eol-type orig-eol-type)
+ coding-system
+ (setq orig-eol-type (coding-system-eol-type base))
+ (if (null orig-eol-type)
+ (coding-system-property base eol-type))))))))
;; (defun coding-system-change-text-conversion (coding-system coding)
;; "Return a coding system which differs from CODING-SYSTEM in text conversion.
setup-function value is a function to call to switch to this
language environment.
exit-function value is a function to call to leave this
- language environment.
+ language environment.
coding-system value is a list of coding systems that are good
for saving text written in this language environment.
This list serves as suggestions to the user;
;; Set up menu items for this language env.
(let ((doc (assq 'documentation alist)))
(when doc
- ;; (define-key-after describe-map (vector (intern lang-env))
- ;; (cons lang-env 'describe-specified-language-support) t)
+ ;; (define-key-after describe-map (vector (intern lang-env))
+ ;; (cons lang-env 'describe-specified-language-support) t)
(when (featurep 'menubar)
(eval-after-load
"menubar-items.elc"
(vector ,lang-env
'(set-language-environment ,lang-env)
t))))
-
+
(while alist
(set-language-info lang-env (car (car alist)) (cdr (car alist)))
(setq alist (cdr alist)))))
in the format of Lisp expression for registering each input method.
Emacs loads this file at startup time.")
-(defvar leim-list-header (format
+(defvar leim-list-header (format
";;; %s -- list of LEIM (Library of Emacs Input Method)
;;
;; This file contains a list of LEIM (Library of Emacs Input Method)
(if (memq eol-type '(lf crlf cr unix dos mac))
(coding-system-change-eol-conversion default-coding eol-type)
default-coding))
- ;; (setq default-sendmail-coding-system default-coding)
+ ;; (setq default-sendmail-coding-system default-coding)
(while priority
(unless (memq (setq category (car categories)) checked-categories)
(set-coding-category-system category (car priority))
(setq priority (cdr priority)
categories (cdr categories)))
(set-coding-priority-list (nreverse checked-categories))
- ;; (update-coding-systems-internal)
+ ;; (update-coding-systems-internal)
))))
;; Print all arguments with `princ', then print "\n".
(car l)
(coding-system-mnemonic (car l))
(coding-system-doc-string (car l))))
- ;; (let ((aliases (coding-system-get (car l) 'alias-coding-systems)))
- ;; (when aliases
- ;; (princ "\t")
- ;; (princ (cons 'alias: (cdr aliases)))
- ;; (terpri)))
+ ;; (let ((aliases (coding-system-get (car l) 'alias-coding-systems)))
+ ;; (when aliases
+ ;; (princ "\t")
+ ;; (princ (cons 'alias: (cdr aliases)))
+ ;; (terpri)))
(setq l (cdr l))))))))
\f
;;; Charset property
;; (setq desc (or (cdr (assq char iso-2022-control-alist))
;; (char-to-string char)))
;; (let ((i 1)
-;; (len (length str)))
+;; (len (length str)))
;; (while (< i len)
;; (setq char (aref str i))
;; (if (>= char 128)
;; ;; To exclude such tailing bytes, we at first encode one-char
;; ;; string and two-char string, then check how many bytes at the
;; ;; tail of both encoded strings are the same.
-;;
+;;
;; (setq enc1 (string-as-unibyte (encode-coding-string str1 coding-system))
;; i1 (length enc1)
;; enc2 (string-as-unibyte (encode-coding-string str2 coding-system))
;; i2 (length enc2))
;; (while (and (> i1 0) (= (aref enc1 (1- i1)) (aref enc2 (1- i2))))
;; (setq i1 (1- i1) i2 (1- i2)))
-;;
+;;
;; ;; Now (substring enc1 i1) and (substring enc2 i2) are the same,
;; ;; and they are the extra control sequences at the tail to
;; ;; exclude.
-;;; mule-help.el --- Mule-ized Help functions
+;;; mule-help.el --- Mule-ized Help functions
;; Copyright (C) 1997 by Free Software Foundation, Inc.
;;; Commentary:
-;;
+;;
;;; Code:
;;; By default, Japanese is set as the primary environment.
;;; You can change primary environment in `./lisp/site-init.el by
;;; `set-primary-environment'. For instance,
-;;; (set-primary-environment 'chinese)
+;;; (set-primary-environment 'chinese)
;;; makes Chinese the primary environment.
;;; If you are still not satisfied with the settings, you can
;;; override them after the above line. For instance,
-;;; (set-default-buffer-file-coding-system 'big5)
+;;; (set-default-buffer-file-coding-system 'big5)
;;; makes big5 be used for file I/O by default.
;;; If you are not satisfied with other default settings in this file,
;;; override any of them also in `./lisp/site-init.el'. For instance,
(load (format "%s%s/locale-start"
(locate-data-directory "start-files")
lang) t t)))
-
+
(when current-language-environment
;; Translate remaining args on command line using file-name-coding-system
(loop for arg in-ref command-line-args-left do
(setf arg (decode-coding-string arg file-name-coding-system)))
-
+
;; rman seems to be incompatible with encoded text
(and-boundp 'Manual-use-rosetta-man
(setq Manual-use-rosetta-man nil))
(with-fboundp 'setenv
(setenv "LC_MESSAGES" "C")
(setenv "LC_TIME" "C")))))
-
+
;; Register available input methods by loading LEIM list file.
(load "leim-list.el" 'noerror 'nomessage 'nosuffix)
)
;; Chinese fonts
"-*-*-medium-r-*--*-gb2312.1980-*"
-
+
;; Use One font specification for CNS chinese
;; Too many variations in font naming
"-*-fixed-medium-r-*--*-cns11643*-*"
;; "-*-fixed-medium-r-*--*-cns11643.5-0"
;; "-*-fixed-medium-r-*--*-cns11643.6-0"
;; "-*-fixed-medium-r-*--*-cns11643.7-0"
-
+
"-*-fixed-medium-r-*--*-big5*-*"
"-*-fixed-medium-r-*--*-sisheng_cwnn-0"
;; Other fonts
-
+
;; "-*-fixed-medium-r-*--*-viscii1.1-1"
-
+
;; "-*-fixed-medium-r-*--*-mulearabic-0"
;; "-*-fixed-medium-r-*--*-mulearabic-1"
;; "-*-fixed-medium-r-*--*-mulearabic-2"
;; rx' == (tis620-to-thai-xtis-second-byte-bitpattern rx)
;; r3 == "no vower nor tone"
;; r4 == (charset-id 'thai-xtis)
-;;
+;;
;; | input (= r0)
;; state |--------------------------------------------
;; | consonant | vowel | tone
;; r1 == C | WRITE r1,r2 | WRITE r1,r2 | WRITE r1,r2|r0'
;; r2 == V | r1 = r0 | WRITE r0,r3 | r1 = r2 = 0
;; | r2 = 0 | r1 = r2 = 0 |
-;;
-;;
-;; | input (= r0)
+;;
+;;
+;; | input (= r0)
;; state |-----------------------------------------
;; | symbol | ASCII | EOF
;; ---------+-------------+-------------+-------------
64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79
80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95
96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111
- 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127
+ 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127
?\e,2U\e(B ?\e,2!\e(B ?\e,2"\e(B ?\e,2#\e(B ?\e,2$\e(B ?\e,2%\e(B ?\e,2&\e(B ?\e,2'\e(B ?\e,2(\e(B ?\e,2)\e(B ?\e,2*\e(B ?\e,2+\e(B ?\e,2,\e(B ?\e,2-\e(B ?\e,2.\e(B ?\e,2/\e(B
?\e,20\e(B ?\e,21\e(B ?\e,22\e(B ?\e,25\e(B ?\e,2~\e(B ?\e,2>\e(B ?\e,26\e(B ?\e,27\e(B ?\e,28\e(B ?\e,2v\e(B ?\e,2w\e(B ?\e,2o\e(B ?\e,2|\e(B ?\e,2{\e(B ?\e,2x\e(B ?\e,2O\e(B
?\e,2u\e(B ?\e,1!\e(B ?\e,1"\e(B ?\e,1#\e(B ?\e,1$\e(B ?\e,1%\e(B ?\e,1&\e(B ?\e,1'\e(B ?\e,1(\e(B ?\e,1)\e(B ?\e,1*\e(B ?\e,1+\e(B ?\e,1,\e(B ?\e,1-\e(B ?\e,1.\e(B ?\e,1/\e(B
64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79
80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95
96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111
- 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127
+ 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127
?\e,2`\e(B ?\e,2d\e(B ?\e,2c\e(B ?\e,2a\e(B ?\e,2U\e(B ?\e,2#\e(B ?\e,2'\e(B ?\e,2h\e(B ?\e,2k\e(B ?\e,2(\e(B ?\e,2i\e(B ?\e,2)\e(B ?\e,2.\e(B ?\e,2l\e(B ?\e,2o\e(B ?\e,2n\e(B
?\e,2m\e(B ?\e,28\e(B ?\e,2r\e(B ?\e,2v\e(B ?\e,2u\e(B ?\e,2s\e(B ?\e,2w\e(B ?\e,25\e(B ?\e,26\e(B ?\e,27\e(B ?\e,2^\e(B ?\e,2>\e(B ?\e,2~\e(B ?\e,2y\e(B ?\e,2|\e(B ?\e,2{\e(B
160 ?\e,2e\e(B ?\e,2b\e(B ?\e,2j\e(B ?\e,2t\e(B ?\e,2=\e(B ?\e,2_\e(B ?\e,2p\e(B ?\e,1e\e(B ?\e,1b\e(B ?\e,1j\e(B ?\e,1t\e(B ?\e,1>\e(B ?\e,1y\e(B ?\e,1p\e(B ?\e,2"\e(B
(if (r0 < 128)
;; ASCII
(write-read-repeat r0)
- ;; not ASCII
+ ;; not ASCII
(if (r0 != ,leading-code-private-11)
;; not Vietnamese
(write-read-repeat r0)
ttl is the time-to-live (15 for site, 63 for region and 127 for world).
WARNING: it is *strongly* recommended to avoid using groups beginning with
- 224 or 239. Such groups are considered 'admin' groups, and may
- behave in a surprising way ..."
+ 224 or 239. Such groups are considered 'admin' groups, and may
+ behave in a surprising way ..."
(let (dest port ttl)
;; We check only the general form of the multicast address.
;; The rest will be handled by the internal function.
;;; Comments:
;; This file provides some additional functionality not worth
;; implementing in C.
-;;
+;;
;; Note to myself: number.el is a stupid name :(
\f
(defun canonical-valuation (number)
"Return the canonical valuation of NUMBER."
(cond ((archimedeanp number)
- (abs number))))
+ (abs number))))
\f
(provide 'number)
Note: Use this before any other references (defvar/defcustom) to NEWVAR."
(let ((needs-setting (and (boundp oldvar) (not (boundp newvar))))
- (value (and (boundp oldvar) (symbol-value oldvar))))
+ (value (and (boundp oldvar) (symbol-value oldvar))))
(defvaralias oldvar newvar)
(make-obsolete-variable oldvar newvar)
(and needs-setting (set newvar value))))
;; Can't make this obsolete. easymenu depends on it.
(make-compatible 'add-menu 'add-submenu)
-(define-obsolete-function-alias 'package-get-download-menu
+(define-obsolete-function-alias 'package-get-download-menu
'package-ui-download-menu)
;;;;;;;;;;;;;;;;;;;;;;;;;;;; minibuffer
(make-obsolete-variable 'executing-macro 'executing-kbd-macro)
-(define-compatible-function-alias 'interactive-form
+(define-compatible-function-alias 'interactive-form
'function-interactive) ;GNU 21.1
(define-compatible-function-alias 'assq-delete-all
'remassq) ;GNU 21.1
(when ms
(declare-fboundp (play-media-stream ms device)))))
(make-obsolete #'play-sound-file
- "use `make-media-stream' and `play-media-stream' instead.")
+ "use `make-media-stream' and `play-media-stream' instead.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;; window-system objects
(let ((path-list (paths-decode-directory-path env-value 'drop-empties)))
(cond ((eq type 'site)
(while path-list
- (if (equal (file-name-nondirectory
+ (if (equal (file-name-nondirectory
(directory-file-name (car path-list)))
"site-packages")
(setq top-dir (car path-list)))
(setq path-list (cdr path-list))))
((eq type 'sxemacs)
(while path-list
- (if (equal (file-name-nondirectory
+ (if (equal (file-name-nondirectory
(directory-file-name (car path-list)))
"sxemacs-packages")
(setq top-dir (car path-list)))
(setq path-list (cdr path-list))))
((eq type 'std)
(while path-list
- (if (equal (file-name-nondirectory
+ (if (equal (file-name-nondirectory
(directory-file-name (car path-list)))
"xemacs-packages")
(setq top-dir (car path-list)))
(setq path-list (cdr path-list))))
((eq type 'mule)
(while path-list
- (if (equal (file-name-nondirectory
+ (if (equal (file-name-nondirectory
(directory-file-name (car path-list)))
"mule-packages")
(setq top-dir (car path-list)))
(packages-compute-package-locations user-init-directory)))))
(cond ((eq type 'site)
(while path-list
- (if (equal (file-name-nondirectory
+ (if (equal (file-name-nondirectory
(directory-file-name (car path-list)))
"site-packages")
(setq top-dir (car path-list)))
(setq path-list (cdr path-list))))
((eq type 'sxemacs)
(while path-list
- (if (equal (file-name-nondirectory
+ (if (equal (file-name-nondirectory
(directory-file-name (car path-list)))
"sxemacs-packages")
(setq top-dir (car path-list)))
(setq path-list (cdr path-list))))
((eq type 'std)
(while path-list
- (if (equal (file-name-nondirectory
+ (if (equal (file-name-nondirectory
(directory-file-name (car path-list)))
"xemacs-packages")
(setq top-dir (car path-list)))
(setq path-list (cdr path-list))))
((eq type 'mule)
(while path-list
- (if (equal (file-name-nondirectory
+ (if (equal (file-name-nondirectory
(directory-file-name (car path-list)))
"mule-packages")
(setq top-dir (car path-list)))
;; neither can the user, nothing left to do except barf. :-(
(error 'search-failed
(format
- "Can't find suitable installation directory for package: %s"
+ "Can't find suitable installation directory for package: %s"
package))))))))))
(defun package-admin-get-manifest-file (pkg-topdir package)
(if (eq system-type 'windows-nt)
(setq case-fold-search t))
- (setq regexp (concat "\\bpkginfo"
+ (setq regexp (concat "\\bpkginfo"
(char-to-string directory-sep-char)
"MANIFEST\\...*"))
;; Here, we don't use a single regexp because we want to search
;; the directories for a package name in a particular order.
(if (catch 'done
- (let ((dirs '("lisp" "man"))
+ (let ((dirs '("lisp" "man"))
rexp)
(while dirs
(setq rexp (concat "\\b" (car dirs)
This is a feeble attempt at making a portable rmdir."
(setq directory (file-name-as-directory directory))
(let ((files (directory-files directory nil nil nil t))
- (dirs (directory-files directory nil nil nil 'dirs)))
+ (dirs (directory-files directory nil nil nil 'dirs)))
(while dirs
(if (not (member (car dirs) '("." "..")))
- (let ((dir (expand-file-name (car dirs) directory)))
- (condition-case err
- (if (file-symlink-p dir) ;; just in case, handle symlinks
- (delete-file dir)
- (package-admin-rmtree dir))
- (file-error
- (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err)))))
- (setq dirs (cdr dirs))))
+ (let ((dir (expand-file-name (car dirs) directory)))
+ (condition-case err
+ (if (file-symlink-p dir) ;; just in case, handle symlinks
+ (delete-file dir)
+ (package-admin-rmtree dir))
+ (file-error
+ (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err)))))
+ (setq dirs (cdr dirs))))
(while files
(condition-case err
- (delete-file (expand-file-name (car files) directory))
- (file-error
- (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err))))
+ (delete-file (expand-file-name (car files) directory))
+ (file-error
+ (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err))))
(setq files (cdr files)))
(condition-case err
- (delete-directory directory)
+ (delete-directory directory)
(file-error
(message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err))))))
;; Retrieve a package and any other required packages from an archive
;;
;;
-;; Note (JV): Most of this no longer applies!
+;; Note (JV): Most of this no longer applies!
;; Note (SY): Definitely no longer applies, but I'm leaving these
;; comments here because there are some nifty ideas here.
;;
:group 'package-get)
;;;###autoload
-(defcustom package-get-package-index-file-location
+(defcustom package-get-package-index-file-location
(car (split-path (or (getenv "EMACSPACKAGEPATH") user-init-directory)))
"*The directory where the package-index file can be found."
:type 'directory
"Update an entry in `package-get-base'."
(let ((existing (assq (car entry) package-get-base)))
(if existing
- (setcdr existing (cdr entry))
+ (setcdr existing (cdr entry))
(setq package-get-base (cons entry package-get-base)))))
(defun package-get-locate-file (file &optional nil-if-not-found no-remote)
(if (file-name-absolute-p file)
file
(let ((site package-get-remote)
- (expanded nil))
+ (expanded nil))
(when site
(unless (and no-remote (caar (list site)))
(let ((expn (package-get-remote-filename (car (list site)) file)))
(setq site nil
expanded expn)))))
(or expanded
- (and (not nil-if-not-found)
- file)))))
+ (and (not nil-if-not-found)
+ file)))))
(defun package-get-locate-index-file (no-remote)
- "Locate the package-get index file.
+ "Locate the package-get index file.
Do not return remote paths if NO-REMOTE is non-nil. If the index
file doesn't exist in `package-get-package-index-file-location', ask
package-get-package-index-file-location))
(progn
(save-excursion
- (set-buffer
+ (set-buffer
(find-file-noselect (expand-file-name
package-get-base-filename
package-get-package-index-file-location)))
(interactive
(let ((dflt (package-get-locate-index-file nil)))
(list (read-file-name "Load package-get database: "
- (file-name-directory dflt)
- dflt
- t
- (file-name-nondirectory dflt)))))
+ (file-name-directory dflt)
+ dflt
+ t
+ (file-name-nondirectory dflt)))))
(setq db-file (expand-file-name (or db-file
- (package-get-locate-index-file
- (not force-current)))))
+ (package-get-locate-index-file
+ (not force-current)))))
(if (not (file-exists-p db-file))
(error 'file-error
(format "Package-get database file `%s' does not exist" db-file)))
(format "Package-get database file `%s' not readable" db-file)))
(let ((buf (get-buffer-create "*package database*")))
(unwind-protect
- (save-excursion
- (set-buffer buf)
- (erase-buffer buf)
- (insert-file-contents-literally db-file)
- (package-get-update-base-from-buffer buf)
+ (save-excursion
+ (set-buffer buf)
+ (erase-buffer buf)
+ (insert-file-contents-literally db-file)
+ (package-get-update-base-from-buffer buf)
(if (file-remote-p db-file)
(package-get-maybe-save-index db-file)))
(kill-buffer buf))))
(save-excursion
(goto-char start)
(if (not (re-search-forward "^(package-get-update-base-entry" nil t))
- (error 'search-failed
+ (error 'search-failed
"Buffer does not contain package-get database entries"))
(beginning-of-line)
(let ((count 0))
(while (and (< (point) end)
- (re-search-forward "^(package-get-update-base-entry" nil t))
- (beginning-of-line)
- (let ((entry (read (current-buffer))))
- (if (or (not (consp entry))
- (not (eq (car entry) 'package-get-update-base-entry)))
- (error 'syntax-error
+ (re-search-forward "^(package-get-update-base-entry" nil t))
+ (beginning-of-line)
+ (let ((entry (read (current-buffer))))
+ (if (or (not (consp entry))
+ (not (eq (car entry) 'package-get-update-base-entry)))
+ (error 'syntax-error
"Invalid package-get database entry found"))
- (package-get-update-base-entry
- (car (cdr (car (cdr entry)))))
- (setq count (1+ count))))
+ (package-get-update-base-entry
+ (car (cdr (car (cdr entry)))))
+ (setq count (1+ count))))
(message "Got %d package-get database entries" count))))
;;;###autoload
(package-get-require-base t)
(let ((buf (get-buffer-create "*package database*")))
(unwind-protect
- (save-excursion
- (set-buffer buf)
- (erase-buffer buf)
- (goto-char (point-min))
- (let ((entries package-get-base) entry plist)
- (insert ";; Package Index file -- Do not edit manually.\n")
- (insert ";;;@@@\n")
- (while entries
- (setq entry (car entries))
- (setq plist (car (cdr entry)))
- (insert "(package-get-update-base-entry (quote\n")
- (insert (format "(%s\n" (symbol-name (car entry))))
- (while plist
- (insert (format " %s%s %S\n"
- (if (eq plist (car (cdr entry))) "(" " ")
- (symbol-name (car plist))
- (car (cdr plist))))
- (setq plist (cdr (cdr plist))))
- (insert "))\n))\n;;;@@@\n")
- (setq entries (cdr entries))))
- (insert ";; Package Index file ends here\n")
- (write-region (point-min) (point-max) file))
+ (save-excursion
+ (set-buffer buf)
+ (erase-buffer buf)
+ (goto-char (point-min))
+ (let ((entries package-get-base) entry plist)
+ (insert ";; Package Index file -- Do not edit manually.\n")
+ (insert ";;;@@@\n")
+ (while entries
+ (setq entry (car entries))
+ (setq plist (car (cdr entry)))
+ (insert "(package-get-update-base-entry (quote\n")
+ (insert (format "(%s\n" (symbol-name (car entry))))
+ (while plist
+ (insert (format " %s%s %S\n"
+ (if (eq plist (car (cdr entry))) "(" " ")
+ (symbol-name (car plist))
+ (car (cdr plist))))
+ (setq plist (cdr (cdr plist))))
+ (insert "))\n))\n;;;@@@\n")
+ (setq entries (cdr entries))))
+ (insert ";; Package Index file ends here\n")
+ (write-region (point-min) (point-max) file))
(kill-buffer buf))))
(defun package-get-interactive-package-query (get-version package-symbol)
(if (not (setq fetched-packages
(package-get-all reqd-name reqd-version
fetched-packages
- install-dir)))
+ install-dir)))
(throw 'exit nil))))
(setq this-requires (cdr this-requires))))
fetched-packages))
required by PACKAGES."
(package-get-require-base t)
(let ((orig-packages packages)
- dependencies provided)
+ dependencies provided)
(while packages
(let* ((package (car packages))
- (the-package (package-get-info-find-package
- package-get-base package))
- (this-package (package-get-info-version
- the-package nil))
- (this-requires (package-get-info-prop this-package 'requires))
- (new-depends (set-difference
- (mapcar
- #'(lambda (reqd)
- (let* ((reqd-package (package-get-package-provider reqd))
- (reqd-name (car reqd-package)))
- (if (null reqd-name)
- (error 'search-failed
+ (the-package (package-get-info-find-package
+ package-get-base package))
+ (this-package (package-get-info-version
+ the-package nil))
+ (this-requires (package-get-info-prop this-package 'requires))
+ (new-depends (set-difference
+ (mapcar
+ #'(lambda (reqd)
+ (let* ((reqd-package (package-get-package-provider reqd))
+ (reqd-name (car reqd-package)))
+ (if (null reqd-name)
+ (error 'search-failed
(format "Unable to find a provider for %s" reqd)))
- reqd-name))
- this-requires)
- dependencies))
- (this-provides (package-get-info-prop this-package 'provides)))
- (setq dependencies
- (union dependencies new-depends))
- (setq provided
- (union provided (union (list package) this-provides)))
- (setq packages
- (union new-depends (cdr packages)))))
+ reqd-name))
+ this-requires)
+ dependencies))
+ (this-provides (package-get-info-prop this-package 'provides)))
+ (setq dependencies
+ (union dependencies new-depends))
+ (setq provided
+ (union provided (union (list package) this-provides)))
+ (setq packages
+ (union new-depends (cdr packages)))))
(set-difference dependencies orig-packages)))
(defun package-get-load-package-file (lispdir file)
(when (memq item (package-get-info (caar pkgs) field))
(setq results (push (caar pkgs) results)))
(setq pkgs (cdr pkgs)))))
- (t
+ (t
(error 'wrong-type-argument field)))
(if (interactive-p)
(if arg
(package-get-info-version
(package-get-info-find-package package-get-base
package) version))
- (latest (package-get-info-prop this-package 'version))
- (installed (package-get-key package :version))
+ (latest (package-get-info-prop this-package 'version))
+ (installed (package-get-key package :version))
(found nil)
(search-dir package-get-remote)
(base-filename (package-get-info-prop this-package 'filename))
filenames full-package-filename)
(if (and (equal (package-get-info package 'category) "mule")
(not (featurep 'mule)))
- (error 'invalid-state
+ (error 'invalid-state
"Mule packages can't be installed with a non-Mule SXEmacs"))
(if (null this-package)
(if package-get-remote
;; If they asked for the latest using version=nil, don't get an older
;; version than we already have.
(if installed
- (if (> (if (stringp installed)
- (string-to-number installed)
- installed)
- (if (stringp latest)
- (string-to-number latest)
- latest))
- (if (not (null version))
- (warn "Installing %s package version %s, you had a newer version %s"
+ (if (> (if (stringp installed)
+ (string-to-number installed)
+ installed)
+ (if (stringp latest)
+ (string-to-number latest)
+ latest))
+ (if (not (null version))
+ (warn "Installing %s package version %s, you had a newer version %s"
package latest installed)
- (warn "Skipping %s package, you have a newer version %s"
+ (warn "Skipping %s package, you have a newer version %s"
package installed)
- (throw 'skip-update t))))
+ (throw 'skip-update t))))
;; Contrive a list of possible package filenames.
;; Ugly. Is there a better way to do this?
(setq packages (cdr packages)))
(when (interactive-p)
(if found
- (message "%S" found)
- (message "No appropriate package found")))
+ (message "%S" found)
+ (message "No appropriate package found")))
found))
(defun package-get-ever-installed-p (pkg &optional notused)
:tag "Install Location"
:type '(choice (const :tag "Automatic" nil)
(directory)))
-
+
(defcustom pui-list-verbose t
"*If non-nil, display verbose info in the package list buffer."
:group 'pui
Set this to `nil' to use the `default' face."
:group 'pui
:type 'face)
-
+
(defcustom pui-info-buffer "*Packages*"
"*Buffer to use for displaying package information."
:group 'pui
(let ((m (make-sparse-keymap)))
(set-keymap-name m 'pui-package-keymap)
(define-key m 'button2 'pui-toggle-package-event)
-;; We use a popup menu
+;; We use a popup menu
(define-key m 'button3 'pui-popup-context-sensitive)
m)
"Keymap to use over package names/descriptions.")
(defun package-ui-add-site (site)
"Add site to package-get-remote and possibly offer to update package list."
(let ((had-none (null package-get-remote)))
- (setq package-get-remote site)
+ (setq package-get-remote site)
(when (and had-none package-get-was-current
(y-or-n-p "Update Package list?"))
(setq package-get-was-current nil)
(defun package-ui-download-menu ()
"Build the `Add Download Site' menu."
(mapcar (lambda (site)
- (vector (car site)
- `(if (equal package-get-remote (quote ,(cdr site)))
- (setq package-get-remote nil)
- (package-ui-add-site (quote ,(cdr site))))
+ (vector (car site)
+ `(if (equal package-get-remote (quote ,(cdr site)))
+ (setq package-get-remote nil)
+ (package-ui-add-site (quote ,(cdr site))))
;; I've used radio buttons so that only a single
;; site can be selected, but they are in fact
;; toggles. SY.
- :style 'radio
- :selected `(equal package-get-remote (quote ,(cdr site)))))
- package-get-download-sites))
+ :style 'radio
+ :selected `(equal package-get-remote (quote ,(cdr site)))))
+ package-get-download-sites))
;;;###autoload
(defun package-ui-pre-release-download-menu ()
"Build the 'Pre-Release Download Sites' menu."
(mapcar (lambda (site)
- (vector (car site)
- `(if (equal package-get-remote (quote ,(cdr site)))
- (setq package-get-remote nil)
- (package-ui-add-site (quote ,(cdr site))))
+ (vector (car site)
+ `(if (equal package-get-remote (quote ,(cdr site)))
+ (setq package-get-remote nil)
+ (package-ui-add-site (quote ,(cdr site))))
;; I've used radio buttons so that only a single
;; site can be selected, but they are in fact
;; toggles. SY.
- :style 'radio
- :selected `(equal package-get-remote (quote ,(cdr site)))))
- package-get-pre-release-download-sites))
+ :style 'radio
+ :selected `(equal package-get-remote (quote ,(cdr site)))))
+ package-get-pre-release-download-sites))
;;;###autoload
(defun package-ui-site-release-download-menu ()
"Build the 'Site Release Download Sites' menu."
(mapcar (lambda (site)
- (vector (car site)
- `(if (equal package-get-remote (quote ,(cdr site)))
- (setq package-get-remote nil)
- (package-ui-add-site (quote ,(cdr site))))
+ (vector (car site)
+ `(if (equal package-get-remote (quote ,(cdr site)))
+ (setq package-get-remote nil)
+ (package-ui-add-site (quote ,(cdr site))))
;; I've used radio buttons so that only a single
;; site can be selected, but they are in fact
;; toggles. SY.
- :style 'radio
- :selected `(equal package-get-remote (quote ,(cdr site)))))
- package-get-site-release-download-sites))
+ :style 'radio
+ :selected `(equal package-get-remote (quote ,(cdr site)))))
+ package-get-site-release-download-sites))
;;;###autoload
(defun pui-set-local-package-get-directory ()
Note that no provision is made for saving any changes made by this function.
It exists mainly as a convenience for one-time package installations from
disk."
- (interactive)
+ (interactive)
(let ((dir (read-directory-name
"New package binary directory to add? "
nil nil t)))
(defun pui-package-symbol-char (pkg-sym version)
(progn
(if (package-get-info-find-package packages-package-list pkg-sym)
- (let ((installed (package-get-key pkg-sym :version)))
- (if (>= (if (stringp installed)
- (string-to-number installed)
- installed)
- (if (stringp version)
- (string-to-number version)
- version))
- (list " " pui-up-to-date-package-face)
- (list "*" pui-outdated-package-face)))
+ (let ((installed (package-get-key pkg-sym :version)))
+ (if (>= (if (stringp installed)
+ (string-to-number installed)
+ installed)
+ (if (stringp version)
+ (string-to-number version)
+ version))
+ (list " " pui-up-to-date-package-face)
+ (list "*" pui-outdated-package-face)))
(list "-" pui-uninstalled-package-face))))
(defun pui-update-package-display (extent &optional pkg-sym version)
(setq pui-selected-packages
(delete pkg-sym pui-selected-packages)))
(pui-update-package-display extent pkg-sym)))
-
+
(defun pui-toggle-package-delete-key ()
"Select/unselect package for removal, using the keyboard."
(defun pui-install-selected-packages ()
"Install selected packages."
(interactive)
- (let ((tmpbuf "*Packages-To-Remove*")
+ (let ((tmpbuf "*Packages-To-Remove*")
do-delete)
(when pui-deleted-packages
(save-window-excursion
(setq tmpbuf (get-buffer-create tmpbuf))
(display-buffer tmpbuf)
(setq do-delete (yes-or-no-p "Remove these packages? "))
- (kill-buffer tmpbuf))
+ (kill-buffer tmpbuf))
(when do-delete
(message "Deleting selected packages ...") (sit-for 0)
(mapcar (lambda (pkg)
pkg (package-admin-get-install-dir pkg)))
(nreverse pui-deleted-packages))
(message "Packages deleted"))))
-
- (let ((tmpbuf "*Packages-To-Install*")
+
+ (let ((tmpbuf "*Packages-To-Install*")
do-install)
(if pui-selected-packages
(progn
(if (catch 'done
(mapcar (lambda (pkg)
(if (not (package-get pkg nil nil
- pui-package-install-dest-dir))
+ pui-package-install-dest-dir))
(throw 'done nil)))
(nreverse pui-selected-packages))
t)
(let ((tmpbuf "*Required-Packages*") do-select)
(if pui-selected-packages
(let ((dependencies
- (delq nil (mapcar
- (lambda (pkg)
- (let ((installed
- (package-get-key pkg :version))
- (current
- (package-get-info-prop
- (package-get-info-version
- (package-get-info-find-package
- package-get-base pkg) nil)
- 'version)))
- (if (or (null installed)
- (< (if (stringp installed)
- (string-to-number installed)
- installed)
- (if (stringp current)
- (string-to-number current)
- current)))
- pkg
- nil)))
- (package-get-dependencies pui-selected-packages)))))
+ (delq nil (mapcar
+ (lambda (pkg)
+ (let ((installed
+ (package-get-key pkg :version))
+ (current
+ (package-get-info-prop
+ (package-get-info-version
+ (package-get-info-find-package
+ package-get-base pkg) nil)
+ 'version)))
+ (if (or (null installed)
+ (< (if (stringp installed)
+ (string-to-number installed)
+ installed)
+ (if (stringp current)
+ (string-to-number current)
+ current)))
+ pkg
+ nil)))
+ (package-get-dependencies pui-selected-packages)))))
;; Don't change window config when asking the user if he really
;; wants to add the packages. We do this to avoid messing up
;; the window configuration if errors occur (we don't want to
(with-output-to-temp-buffer tmpbuf
(display-completion-list (sort
(mapcar #'(lambda (pkg)
- (symbol-name pkg))
+ (symbol-name pkg))
dependencies)
'string<)
:activate-callback nil
(setq do-select (y-or-n-p "Select these packages? "))
(kill-buffer tmpbuf))
(if do-select
- (progn
- (setq pui-selected-packages
- (union pui-selected-packages dependencies))
- (map-extents #'(lambda (extent maparg)
- (pui-update-package-display extent))
- nil nil nil nil nil 'pui)
- (message "added dependencies"))
+ (progn
+ (setq pui-selected-packages
+ (union pui-selected-packages dependencies))
+ (map-extents #'(lambda (extent maparg)
+ (pui-update-package-display extent))
+ nil nil nil nil nil 'pui)
+ (message "added dependencies"))
(clear-message)))
(error 'invalid-operation
"No packages have been selected!"))))
Maintainer : %s
Released : %s
Required Packages : %s\n\n"
- pkg-sym inst-auth-ver auth-ver maintainer
+ pkg-sym inst-auth-ver auth-ver maintainer
date req))
(set-extent-property extent 'balloon-help balloon)))
- (format
- "Installed upstream ver: %s Available upstream ver: %s"
+ (format
+ "Installed upstream ver: %s Available upstream ver: %s"
inst-auth-ver auth-ver)))))
(defun pui-display-info (&optional no-error event)
(let (extent)
(save-excursion
(beginning-of-line)
- (if (setq extent (extent-at (point) (current-buffer) 'pui))
+ (if (setq extent (extent-at (point) (current-buffer) 'pui))
(message (pui-help-echo extent t))
(if no-error
(clear-message nil)
info maintainer)
(save-excursion
(beginning-of-line)
- (if (setq extent (extent-at (point) (current-buffer) 'pui))
+ (if (setq extent (extent-at (point) (current-buffer) 'pui))
(progn
(setq ;pkg-sym (extent-property extent 'pui-package)
info (extent-property extent 'pui-info)
(unless package-get-remote
(insert "
Warning: No download sites specified. Package index may be out of date.
- If you intend to install packages, specify download sites first.
+ If you intend to install packages, specify download sites first.
"))
-
+
(if pui-list-verbose
(insert " Latest Installed
Package name Vers. Vers. Description
(setq current-vers (format "%.2f" current-vers))))
(insert
(format "%s %-20s %-5.2f %-5s %s\n"
- (car disp) pkg-sym
+ (car disp) pkg-sym
(if (stringp version)
(string-to-number version)
version)
If the optional third arg PATH is specified, that list of directories
is used instead of `load-path'."
(interactive (list (read-library-name "Locate library: ")
- nil nil
- t))
+ nil nil
+ t))
(let ((result
(locate-file
library
;; make sure paths-find-version-directory and paths-find-site-directory
;; don't both pick up version-independent directories ...
(let ((version-directory (paths-find-version-archindep-directory
- roots base nil nil t))
+ roots base nil nil t))
(site-directory (paths-find-site-archindep-directory roots base)))
(paths-uniq-append
(and version-directory (list version-directory))
(if (> arg 0)
(forward-page arg)
(if (< arg 0)
- (forward-page (1- arg))))
+ (forward-page (1- arg))))
(forward-page)
(push-mark nil t t)
(forward-page -1))
Prefix argument says to turn mode on if positive, off if negative.
When the mode is turned on, if there are newlines in the buffer but no hard
-newlines, ask the user whether to mark as hard any newlines preceding a
+newlines, ask the user whether to mark as hard any newlines preceding a
`paragraph-start' line. From a program, second arg INSERT specifies whether
to do this; it can be `never' to change nothing, t or `always' to force
-marking, `guess' to try to do the right thing with no questions, nil
+marking, `guess' to try to do the right thing with no questions, nil
or anything else to ask the user.
Newlines not marked hard are called \"soft\", and are always internal
(while (and (not (bobp))
(progn (move-to-left-margin)
(looking-at paragraph-separate)))
- (forward-line -1))
+ (forward-line -1))
(if (bobp)
nil
;; Go to end of the previous (non-separating) line.
;;; Commentary:
-;; This code provides the picture-mode commands documented in the Emacs
+;; This code provides the picture-mode commands documented in the Emacs
;; manual. The screen is treated as a semi-infinite quarter-plane with
;; support for rectangle operations and `etch-a-sketch' character
;; insertion in any of eight directions.
(let ((column (current-column))
(indent-tabs-mode nil))
(prog1 (save-excursion
- (if killp
- (delete-extract-rectangle start end)
- (prog1 (extract-rectangle start end)
- (clear-rectangle start end))))
+ (if killp
+ (delete-extract-rectangle start end)
+ (prog1 (extract-rectangle start end)
+ (clear-rectangle start end))))
(move-to-column-force column)
;; XEmacs addition:
(setq zmacs-region-stays nil))))
(props
(condition-case err
(make-dialog-box 'page-setup :device d
- :properties (declare-boundp
+ :properties (declare-boundp
default-msprinter-frame-plist))
(error
(Printer-clear-device)
PROPS, if given, is typically the plist returned from the call to
`make-dialog-box' that displayed the Print box. It contains properties
-relevant to us when we print.
+relevant to us when we print.
Recognized properties are the same as those in `make-dialog-box':
name Printer device name. If omitted, the current system-selected
- printer will be used.
+ printer will be used.
from-page First page to print, 1-based. If omitted, printing starts from
- the beginning.
+ the beginning.
to-page Last page to print, inclusive, If omitted, printing ends at
- the end.
+ the end.
copies Number of copies to print. If omitted, one copy is printed."
(cond ((valid-specifier-tag-p 'msprinter)
;; loop, printing one copy of document per loop. kill and
(setq infile (expand-file-name infile))
(setq inbuf (generate-new-buffer "*call-process*"))
(with-current-buffer inbuf
- ;; Make sure this works with jka-compr
- (let ((file-name-handler-alist nil))
- (insert-file-contents-internal infile nil nil nil nil
- 'binary))))
+ ;; Make sure this works with jka-compr
+ (let ((file-name-handler-alist nil))
+ (insert-file-contents-internal infile nil nil nil nil
+ 'binary))))
(let ((stderr (if (consp buffer) (second buffer) t)))
(if (consp buffer) (setq buffer (car buffer)))
(setq buffer
(apply 'call-process-internal program infile buffer displayp args))
(defun call-process-region (start end program
- &optional deletep buffer displayp
- &rest args)
+ &optional deletep buffer displayp
+ &rest args)
"Send text from START to END to a synchronous process running PROGRAM.
Delete the text if fourth arg DELETEP is non-nil.
(error
'unimplemented
"backgrounding a shell command requires package `background'")))
-
+
(shell-command-on-region (point) (point) command output-buffer)))))
;; We have a sentinel to prevent insertion of a termination message
lost packets."
(open-network-stream-internal name buffer host service protocol))
-(defun open-network-server-stream
+(defun open-network-server-stream
(name buffer host service &optional
- protocol acceptor filter sentinel)
+ protocol acceptor filter sentinel)
"Returns a process object to represent the listening connection. When a
new connection request arrives, it is automatically accepted. A
network-stream process is automatically created for that
acceptor function is called. If defined filter and sentinel are set
for the new connection process .
-Input and output work as for subprocesses; `delete-process' closes it.
+Input and output work as for subprocesses; `delete-process' closes it.
-Args are NAME BUFFER HOST SERVICE &optional PROTOCOL ACCEPTOR .
+Args are NAME BUFFER HOST SERVICE &optional PROTOCOL ACCEPTOR .
NAME is name for process. It is modified if necessary to make it
unique.
specify an output stream or filter function to handle the output. No
real process output of listening process is expected. However the
name of this buffer will be used as a base for generating a new
- buffer name for the accepted connections.
+ buffer name for the accepted connections.
The BUFFER may be also nil, meaning that this process is not
associated with any buffer. In this case a filter should be specified
- otherwise there will be no way to retrieve the process output.
+ otherwise there will be no way to retrieve the process output.
BUFFER may also be 'auto in which case a buffer is automatically
created for the accepted connection.
acceptance with the accepted connection process as the single argument.
Seventh argument FILTER is a function which will be set as filter for
the accepted connections automatically. See `set-process-filter' for
- more details.
+ more details.
Eight argument SENTINEL is a function which will be set as sentinel
the accepted connections automatically. see `set-process-sentinel'
for more details.
will override the FILTER and SENTINEL args to this function.
"
(open-network-server-stream-internal name buffer host service
- protocol acceptor filter sentinel))
+ protocol acceptor filter sentinel))
(defun shell-quote-argument (argument)
"Quote an argument for passing as argument to an inferior shell."
(interactive "*r\nsString rectangle: ")
(defvar pending-delete-mode)
(apply-on-rectangle 'string-rectangle-line start end string
- (and (boundp 'pending-delete-mode) pending-delete-mode)))
+ (and (boundp 'pending-delete-mode) pending-delete-mode)))
;;;###autoload
(defun replace-rectangle (start end string)
;; For example:
;;
;; (let ((strings '("cond" "if" "when" "unless" "while"
-;; "let" "let*" "progn" "prog1" "prog2"
-;; "save-restriction" "save-excursion" "save-window-excursion"
-;; "save-current-buffer" "save-match-data"
-;; "catch" "throw" "unwind-protect" "condition-case")))
+;; "let" "let*" "progn" "prog1" "prog2"
+;; "save-restriction" "save-excursion" "save-window-excursion"
+;; "save-current-buffer" "save-match-data"
+;; "catch" "throw" "unwind-protect" "condition-case")))
;; (concat "(" (regexp-opt strings t) "\\>"))
;; => "(\\(c\\(?:atch\\|ond\\(?:ition-case\\)?\\)\\|if\\|let\\*?\\|prog[12n]\\|save-\\(?:current-buffer\\|excursion\\|match-data\\|restriction\\|window-excursion\\)\\|throw\\|un\\(?:less\\|wind-protect\\)\\|wh\\(?:en\\|ile\\)\\)\\>"
;;
(defconst regexp-opt-not-groupie*-re
(let* ((harmless-ch "[^\\\\[]")
- (esc-pair-not-lp "\\\\[^(]")
- (class-harmless-ch "[^][]")
- (class-lb-harmless "[^]:]")
- (class-lb-colon-maybe-charclass ":\\([a-z]+:]\\)?")
- (class-lb (concat "\\[\\(" class-lb-harmless
- "\\|" class-lb-colon-maybe-charclass "\\)"))
- (class
- (concat "\\[^?]?"
- "\\(" class-harmless-ch
- "\\|" class-lb "\\)*"
- "\\[?]")) ; special handling for bare [ at end of re
- (shy-lp "\\\\(\\?:"))
+ (esc-pair-not-lp "\\\\[^(]")
+ (class-harmless-ch "[^][]")
+ (class-lb-harmless "[^]:]")
+ (class-lb-colon-maybe-charclass ":\\([a-z]+:]\\)?")
+ (class-lb (concat "\\[\\(" class-lb-harmless
+ "\\|" class-lb-colon-maybe-charclass "\\)"))
+ (class
+ (concat "\\[^?]?"
+ "\\(" class-harmless-ch
+ "\\|" class-lb "\\)*"
+ "\\[?]")) ; special handling for bare [ at end of re
+ (shy-lp "\\\\(\\?:"))
(concat "\\(" harmless-ch "\\|" esc-pair-not-lp
- "\\|" class "\\|" shy-lp "\\)*"))
+ "\\|" class "\\|" shy-lp "\\)*"))
"Matches any part of a regular expression EXCEPT for non-shy \"\\\\(\"s")
;;;###autoload
;; Count the number of open parentheses in REGEXP.
(let ((count 0) start)
(while
- (progn
- (string-match regexp-opt-not-groupie*-re regexp start)
- (setq start ( + (match-end 0) 2)) ; +2 for "\\(" after match-end.
- (<= start (length regexp)))
- (setq count (1+ count)))
+ (progn
+ (string-match regexp-opt-not-groupie*-re regexp start)
+ (setq start ( + (match-end 0) 2)) ; +2 for "\\(" after match-end.
+ (<= start (length regexp)))
+ (setq count (1+ count)))
count)))
\f
;;; Workhorse functions.
at point, and point moves to the end of that number.
Interactively, NUMBER is the prefix arg (none means nil)."
(interactive "P\ncNumber to register: ")
- (set-register register
+ (set-register register
(if number
(prefix-numeric-value number)
(if (looking-at "\\s-*-?[0-9]+")
(read-from-minibuffer
(format "List lines matching regexp (default `%s'): "
default) nil nil nil 'regexp-history nil
- default)
+ default)
(read-from-minibuffer
"List lines matching regexp: "
nil nil nil
(prevpos (point-min))
;; The rest of this function is very different from FSF.
;; Presumably that's due to Jamie's misfeature
- (final-context-start (make-marker)))
+ (final-context-start (make-marker)))
(if (not list-matching-lines-whole-buffer)
(save-excursion
(beginning-of-line)
(next-command-event event)))
(defun perform-replace (from-string replacements
- query-flag regexp-flag delimited-flag
+ query-flag regexp-flag delimited-flag
&optional repeat-count map)
"Subroutine of `query-replace'. Its complexity handles interactive queries.
Don't use this in your own program unless you want to query and set the mark
STRING should be given if the last search was by `string-match' on STRING."
(if (match-beginning num)
(if string
- (substring string (match-beginning num) (match-end num))
- (buffer-substring (match-beginning num) (match-end num)))))
+ (substring string (match-beginning num) (match-end num))
+ (buffer-substring (match-beginning num) (match-end num)))))
(defmacro save-match-data (&rest body)
"Execute BODY forms, restoring the global value of the match data."
0
(save-excursion
(save-restriction
- (widen)
+ (widen)
(narrow-to-region start end)
(goto-char start)
- (vertical-motion (buffer-size))))))
+ (vertical-motion (buffer-size))))))
\f
;; Resize the minibuffer window to contain the minibuffer's contents.
(when value
(let ((handler-fn (cdr (assq type selection-converter-in-alist))))
(if handler-fn
- (apply handler-fn (list selection type value))
- value))))
+ (apply handler-fn (list selection type value))
+ value))))
(defun select-convert-out (selection type value)
"Attempt to convert the specified internal VALUE for the specified DATA-TYPE
(defun select-convert-from-ip-address (selection type value)
(if (and (stringp value)
- (= (length value) 4))
+ (= (length value) 4))
(format "%d.%d.%d.%d"
- (aref value 0) (aref value 1) (aref value 2) (aref value 3))))
+ (aref value 0) (aref value 1) (aref value 2) (aref value 3))))
(defun select-convert-to-atom (selection type value)
(and (symbolp value) value))
(defun paths-find-site-module-directory (roots)
"Find the site modules directory of the XEmacs hierarchy."
(paths-find-site-archdep-directory roots "site-modules"
- nil
- configure-site-module-directory))
+ nil
+ configure-site-module-directory))
(defun paths-find-lisp-directory (roots)
"Find the main Lisp directory of the XEmacs hierarchy."
(if (paths-file-readable-directory-p guess)
guess
(paths-find-version-archindep-directory
- roots "mule-lisp" nil configure-mule-lisp-directory)))))
+ roots "mule-lisp" nil configure-mule-lisp-directory)))))
(defun paths-find-ffi-lisp-directory (roots &optional lisp-directory)
"Find the FFI Lisp directory of the SXEmacs hierarchy."
(if (paths-file-readable-directory-p guess)
guess
(or (paths-find-version-archdep-directory
- roots "ffi-lisp" nil)
- (paths-find-version-archindep-directory
- roots "ffi-lisp" nil))))))
+ roots "ffi-lisp" nil)
+ (paths-find-version-archindep-directory
+ roots "ffi-lisp" nil))))))
(defun paths-find-module-directory (roots)
"Find the main modules directory of the SXEmacs hierarchy."
- (or
+ (or
;; for inplace stuff
(paths-find-emacs-directory roots "" "modules"
- nil configure-module-directory)
+ nil configure-module-directory)
(paths-find-architecture-directory roots "modules"
- nil configure-module-directory)))
+ nil configure-module-directory)))
(defun paths-construct-module-load-path
(root module-directory &optional site-module-directory)
(let* ((user-path
(and system-configuration
user-init-directory
- (paths-find-recursive-load-path
+ (paths-find-recursive-load-path
(list (paths-construct-path
(list system-configuration "modules") user-init-directory))
paths-module-load-path-depth)))
(and mule-lisp-directory
(paths-find-recursive-load-path (list mule-lisp-directory)
paths-mule-load-path-depth)))
- (ffi-lisp-load-path
- (and ffi-lisp-directory
+ (ffi-lisp-load-path
+ (and ffi-lisp-directory
(paths-find-recursive-load-path (list ffi-lisp-directory)
paths-ffi-load-path-depth)))
(lisp-load-path
(and module-directory
(paths-construct-module-load-path roots module-directory
site-module-directory)))
- (root-load-path
- (paths-find-recursive-load-path
- (mapcar #'(lambda (root)
- (expand-file-name "lisp" root))
- roots) 1)))
+ (root-load-path
+ (paths-find-recursive-load-path
+ (mapcar #'(lambda (root)
+ (expand-file-name "lisp" root))
+ roots) 1)))
(append env-load-path
emod-load-path
mule-lisp-load-path
ffi-lisp-load-path
lisp-load-path
- root-load-path
+ root-load-path
last-package-load-path)))
(defun paths-construct-info-path (roots early-packages late-packages last-packages)
(list (paths-find-emacs-directory roots "share/" "info" nil configure-info-directory))
(let ((info-directory
(or (paths-find-version-archindep-directory
- roots "info" nil configure-info-directory)
- (paths-find-version-archdep-directory
- roots "info" nil configure-info-directory))))
+ roots "info" nil configure-info-directory)
+ (paths-find-version-archdep-directory
+ roots "info" nil configure-info-directory))))
(and info-directory
(list info-directory)))
(packages-find-package-info-path early-packages)
(defun paths-find-exec-directory (roots)
"Find the binary directory."
(paths-find-architecture-directory roots "lib-src"
- nil configure-exec-directory))
+ nil configure-exec-directory))
(defun paths-construct-exec-path (roots exec-directory
early-packages late-packages last-packages)
are stripped from the file names in the list.
See the documentation for `list-load-path-shadows' for further information."
-
+
(let (shadows ; List of shadowings, to be returned.
dir ; The dir being currently scanned.
curr-files ; This dir's Emacs Lisp files.
(files-seen-this-dir ; Files seen so far in this dir.
(make-hash-table :size 100 :test 'equal))
)
-
+
(dolist (path-elt (or path load-path))
(setq dir (file-truename (or path-elt ".")))
(puthash dir t true-names)
(setq dir (or path-elt "."))
(setq curr-files (if (file-accessible-directory-p dir)
- (directory-files dir nil ".\\.elc?$" t)))
+ (directory-files dir nil ".\\.elc?$" t)))
(and curr-files
(not noninteractive)
(message "Checking %d files in %s..." (length curr-files) dir))
-
+
(clrhash files-seen-this-dir)
(dolist (file curr-files)
;; This test prevents us declaring that XXX.el shadows
;; XXX.elc (or vice-versa) when they are in the same directory.
(puthash file t files-seen-this-dir)
-
+
(if (setq orig-dir (gethash file file-dirs))
;; This file was seen before, we have a shadowing.
(setq shadows
When run interactively, the shadowings \(if any\) are displayed in a
buffer called `*Shadows*'. Shadowings are located by calling the
\(non-interactive\) companion function, `find-emacs-lisp-shadows'."
-
+
(interactive)
(let* ((path (copy-sequence load-path))
(tem path)
is non-nil, and if STRING (either a string or a regular expression according
to REGEXP-FLAG) contains uppercase letters."
`(let ((case-fold-search
- (if (and case-fold-search search-caps-disable-folding)
- (no-upper-case-p ,string ,regexp-flag)
- case-fold-search)))
+ (if (and case-fold-search search-caps-disable-folding)
+ (no-upper-case-p ,string ,regexp-flag)
+ case-fold-search)))
,@body))
(put 'with-search-caps-disable-folding 'lisp-indent-function 2)
(put 'with-search-caps-disable-folding 'edebug-form-spec
`(let ((case-fold-search
(if (and (interactive-p)
case-fold-search search-caps-disable-folding)
- (no-upper-case-p ,string ,regexp-flag)
- case-fold-search)))
+ (no-upper-case-p ,string ,regexp-flag)
+ case-fold-search)))
,@body))
(put 'with-interactive-search-caps-disable-folding 'lisp-indent-function 2)
(put 'with-interactive-search-caps-disable-folding 'edebug-form-spec
(/ (* size (prefix-numeric-value arg)) 10)))
(point-max)))
(cond (arg
- ;; If we went to a place in the middle of the buffer,
- ;; adjust it to the beginning of a line.
- (forward-line 1))
+ ;; If we went to a place in the middle of the buffer,
+ ;; adjust it to the beginning of a line.
+ (forward-line 1))
;; XEmacs change
(scroll-to-end
- ;; If the end of the buffer is not already on the screen,
- ;; then scroll specially to put it near, but not at, the bottom.
- (recenter -3)))))
+ ;; If the end of the buffer is not already on the screen,
+ ;; then scroll specially to put it near, but not at, the bottom.
+ (recenter -3)))))
;; XEmacs (not in FSF)
(defun mark-beginning-of-buffer (&optional arg)
(/ (buffer-size) 10))
(/ (+ 10 (* (buffer-size) (prefix-numeric-value arg))) 10))
(point-min))
- nil
- t))
+ nil
+ t))
(define-function 'mark-bob 'mark-beginning-of-buffer)
;; XEmacs (not in FSF)
(* (prefix-numeric-value arg)
(/ (buffer-size) 10))
(/ (* (buffer-size) (prefix-numeric-value arg)) 10)))
- (point-max))
- nil
- t))
+ (point-max))
+ nil
+ t))
(define-function 'mark-eob 'mark-end-of-buffer)
(defun mark-whole-buffer ()
(with-current-buffer (or buffer (current-buffer))
(let ((cnt (count-lines (point-min) (point-max))))
(message "Buffer has %d lines, %d characters"
- cnt (- (point-max) (point-min)))
+ cnt (- (point-max) (point-min)))
cnt)))
;;; Modified by Bob Weiner, 8/24/95, to print narrowed line number also.
(let* ((char (char-after (point))) ; XEmacs
(beg (point-min))
(end (point-max))
- (pos (point))
+ (pos (point))
(total (buffer-size))
(percent (if (> total 50000)
;; Avoid overflow from multiplying by 100!
;; Inhibit quitting so we can make a quit here
;; look like a C-g typed as a command.
(inhibit-quit t)
- (win (selected-window))
- (buf (current-buffer)))
+ (win (selected-window))
+ (buf (current-buffer)))
(if (pos-visible-in-window-p other-end win)
(progn
;; FSF (I'm not sure what this does -sb)
;; Swap point and mark.
(with-selected-window win
- (with-current-buffer buf
- (goto-char other-end)))
- (sit-for 1)
+ (with-current-buffer buf
+ (goto-char other-end)))
+ (sit-for 1)
;; Swap back.
(with-selected-window win
- (with-current-buffer buf
- (goto-char opoint)))
- ;; If user quit, deactivate the mark
+ (with-current-buffer buf
+ (goto-char opoint)))
+ ;; If user quit, deactivate the mark
;; as C-g would as a command.
(and quit-flag (mark)
- (zmacs-deactivate-region)))))))
+ (zmacs-deactivate-region)))))))
(defun append-next-kill ()
"Cause following command, if it kills, to append to previous kill."
(not (eq (marker-buffer (car global-mark-ring)) buffer))))
;; The last global mark pushed wasn't in this same buffer.
(progn
- (setq global-mark-ring (cons (copy-marker (mark-marker t buffer))
- global-mark-ring))
- (if (> (length global-mark-ring) global-mark-ring-max)
- (progn
- (move-marker (car (nthcdr global-mark-ring-max global-mark-ring))
- nil buffer)
- (setcdr (nthcdr (1- global-mark-ring-max) global-mark-ring) nil)))))
+ (setq global-mark-ring (cons (copy-marker (mark-marker t buffer))
+ global-mark-ring))
+ (if (> (length global-mark-ring) global-mark-ring-max)
+ (progn
+ (move-marker (car (nthcdr global-mark-ring-max global-mark-ring))
+ nil buffer)
+ (setcdr (nthcdr (1- global-mark-ring-max) global-mark-ring) nil)))))
(setq dont-record-current-mark
(not (not (or (and in-shifted-motion-command
(memq 'shifted-motion-commands
(interactive "_P") ; XEmacs
(if column
(progn
- (setq goal-column nil)
- (display-message 'command "No goal column"))
+ (setq goal-column nil)
+ (display-message 'command "No goal column"))
(setq goal-column (current-column))
(lmessage 'command
"Goal column %d (use %s with a prefix arg to unset it)"
(skip-syntax-backward "^ " (match-beginning 0)))))
(setq begpos (point))
;; Compute desired indent.
- ;; XEmacs change: Preserve indentation of comments starting in
- ;; column 0, as documented.
+ ;; XEmacs change: Preserve indentation of comments starting in
+ ;; column 0, as documented.
(cond
((= (current-column) 0)
(goto-char begpos))
(save-restriction
(let ((cs comment-start) (ce comment-end)
numarg)
- (if (consp arg) (setq numarg t)
+ (if (consp arg) (setq numarg t)
(setq numarg (prefix-numeric-value arg))
;; For positive arg > 1, replicate the comment delims now,
;; then insert the replicated strings just once.
ce (concat ce comment-end))
(setq numarg (1- numarg))))
;; Loop over all lines from START to END.
- (narrow-to-region start end)
- (goto-char start)
- (while (not (eobp))
- (if (or (eq numarg t) (< numarg 0))
+ (narrow-to-region start end)
+ (goto-char start)
+ (while (not (eobp))
+ (if (or (eq numarg t) (< numarg 0))
(progn
;; Delete comment start from beginning of line.
(if (eq numarg t)
(looking-at (regexp-quote cs)))
(delete-char (length cs)))))
;; Delete comment end from end of line.
- (if (string= "" ce)
+ (if (string= "" ce)
nil
(if (eq numarg t)
(progn
(delete-char (length ce))))))))
(forward-line 1))
;; Insert at beginning and at end.
- (if (looking-at "[ \t]*$") ()
- (insert cs)
- (if (string= "" ce) ()
- (end-of-line)
- (insert ce)))
- (search-forward "\n" nil 'move)))))))
+ (if (looking-at "[ \t]*$") ()
+ (insert cs)
+ (if (string= "" ce) ()
+ (end-of-line)
+ (insert ce)))
+ (search-forward "\n" nil 'move)))))))
;; XEmacs
(defun prefix-region (prefix)
(interactive "sPrefix string: ")
(if prefix
(let ((count (count-lines (mark) (point))))
- (goto-char (min (mark) (point)))
- (while (> count 0)
- (setq count (1- count))
- (beginning-of-line 1)
- (insert prefix)
- (end-of-line 1)
- (forward-char 1)))))
+ (goto-char (min (mark) (point)))
+ (while (> count 0)
+ (setq count (1- count))
+ (beginning-of-line 1)
+ (insert prefix)
+ (end-of-line 1)
+ (forward-char 1)))))
\f
(defun backward-word (&optional count buffer)
(if (and (eq start oldpoint) (eq end oldpoint))
;; Point is neither within nor adjacent to a word.
(and (not strict)
- (progn
- ;; Look for preceding word in same line.
- (skip-syntax-backward "^w_"
- (save-excursion
- (beginning-of-line) (point)))
- (if (bolp)
+ (progn
+ ;; Look for preceding word in same line.
+ (skip-syntax-backward "^w_"
+ (save-excursion
+ (beginning-of-line) (point)))
+ (if (bolp)
;; No preceding word in same line.
;; Look for following word in same line.
- (progn
- (skip-syntax-forward "^w_"
+ (progn
+ (skip-syntax-forward "^w_"
(save-excursion
- (end-of-line) (point)))
- (setq start (point))
- (skip-syntax-forward "w_")
- (setq end (point)))
- (setq end (point))
- (skip-syntax-backward "w_")
- (setq start (point)))
+ (end-of-line) (point)))
+ (setq start (point))
+ (skip-syntax-forward "w_")
+ (setq end (point)))
+ (setq end (point))
+ (skip-syntax-backward "w_")
+ (setq start (point)))
(buffer-substring start end)))
- (buffer-substring start end)))))
+ (buffer-substring start end)))))
\f
(defcustom fill-prefix nil
"*String for filling to insert at front of new line, or nil for none.
(and zmacs-regions zmacs-region-active-p
(or (marker-buffer (mark-marker t))
(and (extent-live-p zmacs-region-extent)
- (buffer-live-p (extent-object zmacs-region-extent))
- (extent-object zmacs-region-extent)))))
+ (buffer-live-p (extent-object zmacs-region-extent))
+ (extent-object zmacs-region-extent)))))
(defun zmacs-activate-region ()
"Make the region between `point' and `mark' be active (highlighted),
(setq warning-marker (make-marker))
(set-marker warning-marker 1 buffer))
(if temp-buffer-show-function
- (progn
- (funcall temp-buffer-show-function buffer)
+ (progn
+ (funcall temp-buffer-show-function buffer)
(mapc #'(lambda (win) (set-window-start win warning-marker))
(windows-of-buffer buffer nil t)))
(set-window-start (display-buffer buffer) warning-marker))
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)
+(when (file-exists-p site-load-package-file)
(let ((file))
(load site-load-package-file t t t)
;; The `pureload' macro is provided as a clue that a package is
;; #### It is now :) -hroptatyr
(defcustom sound-extension-list (cond ((eq system-type 'linux)
'(".wav" ".au" ".mp3" ".mka" ".ogg"
- ".aac" ".ac3" ".mp4" ".flac"
- ".mpc" ".mpa"))
+ ".aac" ".ac3" ".mp4" ".flac"
+ ".mpc" ".mpa"))
(t
'(".au")))
"List of filename extensions to complete sound file name with."
"Search for FILENAME in `default-sound-directory-list'
with respect to the extensions given by `sound-extension-list'."
(let ((exts (cond ((listp sound-extension-list)
- sound-extension-list)
- ((stringp sound-extension-list)
- (split-string sound-extension-list ":"))
- (t nil))))
+ sound-extension-list)
+ ((stringp sound-extension-list)
+ (split-string sound-extension-list ":"))
+ (t nil))))
(cond ((file-exists-p filename)
(expand-file-name filename))
(defun make-sound-alist-item (filename sound-name &optional volume)
"Return an item suitable for `sound-alist'."
(let* ((file (locate-sound-file filename))
- ;; let's create media-streams
- (stream (make-media-stream :file file))
- (data))
+ ;; let's create media-streams
+ (stream (make-media-stream :file file))
+ (data))
(unless file
(error "Couldn't load sound file %s" filename))
;; (and buf (kill-buffer buf)))
(nconc (list sound-name)
- (if (and volume (not (eq 0 volume)))
- (list ':volume volume))
- (if data
- (list ':sound data))
- (list ':stream stream))))
+ (if (and volume (not (eq 0 volume)))
+ (list ':volume volume))
+ (if data
+ (list ':sound data))
+ (list ':stream stream))))
;;;###autoload
(defun load-sound-file (filename sound-name &optional volume)
(error "volume not an integer or nil"))
(let ((item (make-sound-alist-item filename sound-name volume))
- (old (assq sound-name sound-alist)))
+ (old (assq sound-name sound-alist)))
;; some conses in sound-alist might have been dumped with emacs.
(when old
- (setq sound-alist (delq old (copy-sequence sound-alist))))
+ (setq sound-alist (delq old (copy-sequence sound-alist))))
(setq sound-alist (cons item sound-alist)))
sound-name)
`play-media-stream&'."
(let* ((vol (or volume default-media-stream-volume)))
(if (and (fboundp #'play-media-stream&)
- (not synchronous-sounds))
- (play-media-stream& stream device sentinel vol)
+ (not synchronous-sounds))
+ (play-media-stream& stream device sentinel vol)
(play-media-stream-synchronously stream device sentinel vol))))
;;;###autoload
(let ((data (cdr-safe (assq sound sound-alist))))
(when (and data default-audio-device)
(let ((ms (or (plist-get data :stream)
- (let ((s (plist-get data :sound)))
- (and (stringp s)
- (make-media-stream :data s)))))
- (vol
- (plist-get data :volume
- (or volume default-media-stream-volume bell-volume))))
- (when ms
- (play-media-stream ms device sentinel vol))))))
+ (let ((s (plist-get data :sound)))
+ (and (stringp s)
+ (make-media-stream :data s)))))
+ (vol
+ (plist-get data :volume
+ (or volume default-media-stream-volume bell-volume))))
+ (when ms
+ (play-media-stream ms device sentinel vol))))))
;;; sound.el ends here.
(valid-instantiator-p (cdr inst-pair) specifier-type))
;; case (c)
inst-pair)
-
+
(t
(if noerror t
(signal 'error (list "Invalid specifier tag set"
(add-spec-list-to-specifier specifier spec-list))
(force
(set-specifier specifier
- (apply func
- (or (and (valid-specifier-domain-p locale)
- (specifier-instance specifier))
- default) args)
- locale tag-set)))))
+ (apply func
+ (or (and (valid-specifier-domain-p locale)
+ (specifier-instance specifier))
+ default) args)
+ locale tag-set)))))
(defmacro let-specifier (specifier-list &rest body)
"Add specifier specs, evaluate forms in BODY and restore the specifiers.
(or (valid-specifier-tag-p 'tty)
(define-specifier-tag 'tty (lambda (dev) (eq (device-type dev) 'tty))))
(or (valid-specifier-tag-p 'mswindows)
- (define-specifier-tag 'mswindows (lambda (dev)
+ (define-specifier-tag 'mswindows (lambda (dev)
(eq (device-type dev) 'mswindows))))
;; Add special tag for use by initialization code. Code that
(princ " following options are accepted:
-sd Show dump ID. Ignored when configured without --pdump.
-nd Don't load the dump file. Roughly like old temacs.
- Ignored when configured without --pdump.
+ Ignored when configured without --pdump.
-t <device> Use TTY <device> instead of the terminal for input
- and output. This implies the -nw option.
+ and output. This implies the -nw option.
-nw Inhibit the use of any window-system-specific
- display code: use the current tty.
+ display code: use the current tty.
-batch Execute noninteractively (messages go to stderr).
-debug-init Enter the debugger if an error in the init file occurs.
-unmapped Do not map the initial frame.
(princ " ")
(incf len))))))
(while l
- (let ((name (car (car l)))
- (fn (cdr (car l)))
+ (let ((name (car (car l)))
+ (fn (cdr (car l)))
doc arg cons)
(cond
((and (symbolp fn) (get fn 'undocumented)) nil)
(funcall insert name))
(princ doc)
(terpri))))
- (setq l (cdr l))))
+ (setq l (cdr l))))
(princ (concat "+N <file> Start displaying <file> at line N.
Anything else is considered a file name, and is placed into a buffer for
invocation-name))
(when debug-paths
- (princ (format "invocation: p:%S n:%S\n"
- invocation-directory invocation-name)
- 'external-debugging-output)
- (princ (format "emacs-roots:\n%S\n" emacs-roots)
- 'external-debugging-output))
+ (princ (format "invocation: p:%S n:%S\n"
+ invocation-directory invocation-name)
+ 'external-debugging-output)
+ (princ (format "emacs-roots:\n%S\n" emacs-roots)
+ 'external-debugging-output))
(if (null emacs-roots)
(startup-find-roots-warning))
(setq window-setup-hook nil)
(if error-data
;; re-signal, and don't allow continuation as that will probably
- ;; wipe out the user's .emacs if she hasn't migrated yet!
+ ;; wipe out the user's .emacs if she hasn't migrated yet!
;; Not applicable to SXEmacs --SY.
(signal-error (car error-data) (cdr error-data))))
((string= arg "-user-init-directory")
(setq user-init-directory (file-name-as-directory (pop args))))
((or (string= arg "-u")
- (string= arg "-user"))
+ (string= arg "-user"))
(let* ((user (pop args))
(home-user (concat "~" user)))
(setq user-init-directory (file-name-as-directory
(nreverse new-args)))
-(defconst initial-scratch-message
+(defconst initial-scratch-message
";; This buffer is for notes you don't want to save, and for Lisp evaluation.
;; If you want to create a file, first visit that file with C-x C-f,
;; then enter the text in that file's own buffer.
;;
-;; In \"SXEmacs-speak\", `C-char' and `M-char' are abbreviations that mean
-;; `Control+char' and `Meta+char' (hold down the Control or Meta key while
+;; In \"SXEmacs-speak\", `C-char' and `M-char' are abbreviations that mean
+;; `Control+char' and `Meta+char' (hold down the Control or Meta key while
;; pressing `char').
;;
;; For Lisp evaluation, type an expression, move to the end and hit C-j.
(if load-user-init-file-p
(load-user-init-file))
(setq init-file-had-error nil))
- (error
+ (error
(message "Error in init file: %s" (error-message-string error))
(display-warning 'initialization
(format "An error has occurred while loading %s:
(interactive)
(let ((e last-command-event))
(and (button-press-event-p e)
- (setq e (extent-at (event-point e)
- (event-buffer e)
- 'startup-presentation-hack))
- (setq e (extent-property e 'startup-presentation-hack))
- (if (consp e)
- (apply (car e) (cdr e))
+ (setq e (extent-at (event-point e)
+ (event-buffer e)
+ 'startup-presentation-hack))
+ (setq e (extent-property e 'startup-presentation-hack))
+ (if (consp e)
+ (apply (car e) (cdr e))
(while (keymapp (indirect-function e))
(let ((map e)
(overriding-local-map (indirect-function e)))
(defun splash-frame-present-hack (e v)
;; (set-extent-property e 'mouse-face 'highlight)
;; (set-extent-property e 'keymap
- ;; startup-presentation-hack-keymap)
+ ;; startup-presentation-hack-keymap)
;; (set-extent-property e 'startup-presentation-hack v)
;; (set-extent-property e 'help-echo
- ;; 'startup-presentation-hack-help)
+ ;; 'startup-presentation-hack-help)
)
(defun splash-frame-present (l)
(cond ((stringp l)
- (insert l))
- ((eq (car-safe l) 'face)
- ;; (face name string)
- (let ((p (point)))
- (splash-frame-present (elt l 2))
- (if (fboundp 'set-extent-face)
- (set-extent-face (make-extent p (point))
- (elt l 1)))))
- ((eq (car-safe l) 'key)
- (let* ((c (elt l 1))
- (p (point))
- (k (where-is-internal c nil t)))
- (insert (if k (key-description k)
+ (insert l))
+ ((eq (car-safe l) 'face)
+ ;; (face name string)
+ (let ((p (point)))
+ (splash-frame-present (elt l 2))
+ (if (fboundp 'set-extent-face)
+ (set-extent-face (make-extent p (point))
+ (elt l 1)))))
+ ((eq (car-safe l) 'key)
+ (let* ((c (elt l 1))
+ (p (point))
+ (k (where-is-internal c nil t)))
+ (insert (if k (key-description k)
(format "M-x %s" c)))
- (if (fboundp 'set-extent-face)
- (let ((e (make-extent p (point))))
- (set-extent-face e 'bold)
- (splash-frame-present-hack e c)))))
- ((eq (car-safe l) 'funcall)
- ;; (funcall (fun . args) string)
- (let ((p (point)))
- (splash-frame-present (elt l 2))
- (if (fboundp 'set-extent-face)
- (splash-frame-present-hack (make-extent p (point))
+ (if (fboundp 'set-extent-face)
+ (let ((e (make-extent p (point))))
+ (set-extent-face e 'bold)
+ (splash-frame-present-hack e c)))))
+ ((eq (car-safe l) 'funcall)
+ ;; (funcall (fun . args) string)
+ (let ((p (point)))
+ (splash-frame-present (elt l 2))
+ (if (fboundp 'set-extent-face)
+ (splash-frame-present-hack (make-extent p (point))
(elt l 1)))))
((consp l)
(mapcar 'splash-frame-present l))
- (t
- (backtrace 'external-debugging-output)
- (error "WTF!?"))))
+ (t
+ (backtrace 'external-debugging-output)
+ (error "WTF!?"))))
(defun startup-center-spaces (glyph)
;; Return the number of spaces to insert in order to center
(defun display-splash-frame ()
(let ((logo sxemacs-logo)
(buffer-read-only nil)
- (cramped-p (eq 'tty (console-type))))
+ (cramped-p (eq 'tty (console-type))))
(unless cramped-p (insert "\n"))
(indent-to (startup-center-spaces logo))
(set-extent-begin-glyph (make-extent (point) (point)) logo)
(client-data `[ 1 ,(point) ,(current-buffer) ,elements ])
tmout)
(if (listp elements) ;; A single element to display
- (splash-frame-present (splash-frame-body))
+ (splash-frame-present (splash-frame-body))
;; several elements to rotate
- (splash-frame-present (aref elements 0))
+ (splash-frame-present (aref elements 0))
(setq tmout (add-timeout splash-frame-timeout
'circulate-splash-frame-elements
client-data splash-frame-timeout)))
(packages-compute-package-locations user-init-directory)))
(setq early-package-load-path
- (packages-find-package-load-path early-packages)
- late-package-load-path
- (packages-find-package-load-path late-packages)
- last-package-load-path
- (packages-find-package-load-path last-packages))
+ (packages-find-package-load-path early-packages)
+ late-package-load-path
+ (packages-find-package-load-path late-packages)
+ last-package-load-path
+ (packages-find-package-load-path last-packages))
(if debug-paths
(progn
(setq mule-lisp-directory '()))
(setq ffi-lisp-directory
- (when (fboundp #'ffi-defun)
- (paths-find-ffi-lisp-directory roots
- lisp-directory)))
+ (when (fboundp #'ffi-defun)
+ (paths-find-ffi-lisp-directory roots
+ lisp-directory)))
;; Modules
(setq module-directory (paths-find-module-directory roots))
(if debug-paths
(princ (format "module-directory:\n%S\n" module-directory)
- 'external-debugging-output))
+ 'external-debugging-output))
(setq site-module-directory (and (null inhibit-site-modules)
(paths-find-site-module-directory roots)))
(if (and debug-paths (null inhibit-site-modules))
(princ (format "site-module-directory:\n%S\n" site-module-directory)
- 'external-debugging-output))
+ 'external-debugging-output))
(setq load-path (paths-construct-load-path roots
early-package-load-path
lisp-directory
nil
mule-lisp-directory
- ffi-lisp-directory))
+ ffi-lisp-directory))
(setq Info-directory-list
(paths-construct-info-path roots
'external-debugging-output))
(setq data-directory-list
- (paths-construct-data-directory-list data-directory
- early-packages
- late-packages
- last-packages))
+ (paths-construct-data-directory-list data-directory
+ early-packages
+ late-packages
+ last-packages))
(if debug-paths
(princ (format "data-directory-list:\n%S\n" data-directory-list)
'external-debugging-output)))
(setq warnings (cdr warnings)))
(insert "Perhaps some directories don't exist, "
"or the SXEmacs executable,\n"
- (concat invocation-directory invocation-name)
+ (concat invocation-directory invocation-name)
"\nis in a strange place?")
(princ "\nWARNING:\n" 'external-debugging-output)
"Load autoloads from known locations."
(when (and (not inhibit-autoloads)
- (or lisp-directory module-directory))
+ (or lisp-directory module-directory))
;; ordinary auto-autoloads in lisp/
(let ((aalfile (file-name-sans-extension autoload-file-name)))
(condition-case nil
- (load (expand-file-name aalfile lisp-directory) nil t)
- (error . nil))
+ (load (expand-file-name aalfile lisp-directory) nil t)
+ (error . nil))
;; just load them all
(mapc-internal
#'(lambda (root)
- (condition-case nil
- (load (expand-file-name (concat "lisp/" aalfile) root) nil t)
- (error . nil)))
+ (condition-case nil
+ (load (expand-file-name (concat "lisp/" aalfile) root) nil t)
+ (error . nil)))
emacs-roots)
(when (featurep 'mule)
- (load (expand-file-name aalfile
- (expand-file-name "mule" lisp-directory))
- t t))
+ (load (expand-file-name aalfile
+ (expand-file-name "mule" lisp-directory))
+ t t))
(when (featurep 'modules)
- (load (expand-file-name aalfile module-directory) t t))
+ (load (expand-file-name aalfile module-directory) t t))
(when (fboundp #'ffi-defun)
- (load (expand-file-name aalfile
- (expand-file-name "ffi" lisp-directory))
- t t))))
+ (load (expand-file-name aalfile
+ (expand-file-name "ffi" lisp-directory))
+ t t))))
(unless inhibit-autoloads
(unless inhibit-early-packages
(if (and (not inhibit-early-packages) (not warn-early-package-shadows))
(let ((early-path (mapcar 'file-basename early-package-load-path))
late-load-path)
- (mapc (lambda (path)
+ (mapc (lambda (path)
(unless (member (file-basename path) early-path)
(setq late-load-path (append late-load-path (list path)))))
late-package-load-path)
You can remove this hook yourself using `remove-hook-list'.
See also `add-hook`, `remove-hook` and `add-one-shot-hook'."
- (mapc (lambda (hook)
+ (mapc (lambda (hook)
(add-hook hook function append local))
hook-list))
This makes the hook buffer-local if needed.
To make a hook variable buffer-local, always use
`make-local-hook', not `make-local-variable'."
- (mapc (lambda (hook)
+ (mapc (lambda (hook)
(remove-hook hook function local))
hook-list))
(if (member element (symbol-value list-var))
(symbol-value list-var)
(set list-var
- (if append
- (append (symbol-value list-var) (list element))
- (cons element (symbol-value list-var))))))
+ (if append
+ (append (symbol-value list-var) (list element))
+ (cons element (symbol-value list-var))))))
;; END SYNCHED WITH FSF 21.2
(with-current-buffer ,temp-buffer
,@forms)
(with-current-buffer ,temp-buffer
- (widen)
+ (widen)
(write-region (point-min) (point-max) ,temp-file nil 0)))
(and (buffer-name ,temp-buffer)
(kill-buffer ,temp-buffer))))))
; (declare (indent 0) (debug t))
; `(unwind-protect
; (let ((combine-after-change-calls t))
-; . ,body)
+; . ,body)
; (combine-after-change-execute)))
STRING should be given if the last search was by `string-match' on STRING."
(if (match-beginning num)
(if string
- (substring string (match-beginning num) (match-end num))
- (buffer-substring (match-beginning num) (match-end num)))))
+ (substring string (match-beginning num) (match-end num))
+ (buffer-substring (match-beginning num) (match-end num)))))
(defun match-string-no-properties (num &optional string)
"Return string of text matched by last search, without text properties.
invalid-read-syntax
invalid-regexp
structure-formation-error
- list-formation-error
- malformed-list
- malformed-property-list
- circular-list
- circular-property-list
+ list-formation-error
+ malformed-list
+ malformed-property-list
+ circular-list
+ circular-property-list
invalid-function
no-catch
undefined-keystroke-sequence
buffer-read-only
io-error
file-error
- file-already-exists
- file-locked
- file-supersession
- end-of-file
+ file-already-exists
+ file-locked
+ file-supersession
+ end-of-file
process-error
network-error
gui-error
- dialog-box-error
+ dialog-box-error
sound-error
conversion-error
- text-conversion-error
- image-conversion-error
- base64-conversion-error
- selection-conversion-error
+ text-conversion-error
+ image-conversion-error
+ base64-conversion-error
+ selection-conversion-error
arith-error
range-error
domain-error
(progn
(setq abbrev-table-name-list '())
(fset 'define-abbrev-table (function (lambda (name defs)
- ;; These are fixed-up when abbrev.el loads.
- (setq abbrev-table-name-list
- (cons (cons name defs)
- abbrev-table-name-list)))))))
+ ;; These are fixed-up when abbrev.el loads.
+ (setq abbrev-table-name-list
+ (cons (cons name defs)
+ abbrev-table-name-list)))))))
;;; `functionp' has been moved into C.
;; define-mail-user-agent is in simple.el.
-;; XEmacs; added.
+;; XEmacs; added.
(defun skip-chars-quote (string)
"Return a string that means all characters in STRING will be skipped,
if passed to `skip-chars-forward' or `skip-chars-backward'.
;; -- avoided consing if at all possible.
;; -- didn't slow down operations on non-magic variables (therefore,
;; storing the magic information using `put' is ruled out).
-;;
+;;
;;; Code:
(apply fun 'teach-extended-commands-p args)
(apply fun 'teach-extended-commands-timeout args)))
-(set-magic-variable-handler
+(set-magic-variable-handler
'suggest-key-bindings 'other-predicate
#'(lambda (sym fun args harg)
(and (apply fun 'teach-extended-commands-p args)
(if (consp code)
(setq code (car code)))
(if (or (not (integerp code))
- (> (logand code 127) (length codes)))
+ (> (logand code 127) (length codes)))
nil
(with-output-to-string
(let* ((spec (elt codes (logand code 127)))
`modify-syntax-entry'.
If STRING is invalid, signal an error."
(let* ((bflag nil)
- (b3 0)
- (ch0 (aref string 0))
- (len (length string))
- (code (string-match (regexp-quote (char-to-string ch0))
- (syntax-designator-chars)))
- (i 2)
- ch)
+ (b3 0)
+ (ch0 (aref string 0))
+ (len (length string))
+ (code (string-match (regexp-quote (char-to-string ch0))
+ (syntax-designator-chars)))
+ (i 2)
+ ch)
(or code
- (error "Invalid syntax designator: %S" string))
+ (error "Invalid syntax designator: %S" string))
(while (< i len)
(setq ch (aref string i))
(incf i)
(case ch
- (?1 (setq b3 (logior b3 128)))
- (?2 (setq b3 (logior b3 32)))
- (?3 (setq b3 (logior b3 8)))
- (?4 (setq b3 (logior b3 2)))
- (?5 (setq b3 (logior b3 64)))
- (?6 (setq b3 (logior b3 16)))
- (?7 (setq b3 (logior b3 4)))
- (?8 (setq b3 (logior b3 1)))
- (?a (case ch0
- (?< (setq b3 (logior b3 128)))
- (?> (setq b3 (logior b3 8)))))
- (?b (case ch0
- (?< (setq b3 (logior b3 64) bflag t))
- (?> (setq b3 (logior b3 4) bflag t))))
- (?p (setq code (logior code (lsh 1 7))))
- (?\ nil) ;; ignore for compatibility
- (otherwise
- (error "Invalid syntax description flag: %S" string))))
+ (?1 (setq b3 (logior b3 128)))
+ (?2 (setq b3 (logior b3 32)))
+ (?3 (setq b3 (logior b3 8)))
+ (?4 (setq b3 (logior b3 2)))
+ (?5 (setq b3 (logior b3 64)))
+ (?6 (setq b3 (logior b3 16)))
+ (?7 (setq b3 (logior b3 4)))
+ (?8 (setq b3 (logior b3 1)))
+ (?a (case ch0
+ (?< (setq b3 (logior b3 128)))
+ (?> (setq b3 (logior b3 8)))))
+ (?b (case ch0
+ (?< (setq b3 (logior b3 64) bflag t))
+ (?> (setq b3 (logior b3 4) bflag t))))
+ (?p (setq code (logior code (lsh 1 7))))
+ (?\ nil) ;; ignore for compatibility
+ (otherwise
+ (error "Invalid syntax description flag: %S" string))))
;; default single char style if `b' has not been seen
(if (not bflag)
- (case ch0
- (?< (setq b3 (logior b3 128)))
+ (case ch0
+ (?< (setq b3 (logior b3 128)))
(?> (setq b3 (logior b3 8)))))
(setq code (logior code (lsh b3 16)))
(if (and (> len 1)
(invalid (gettext "**invalid**")) ;(empty "") ;constants
(standard-output (or stream standard-output))
;; #### I18N3 should temporarily set buffer to output-translatable
- (in #'(lambda (string)
- (princ ",\n\t\t\t\t ")
- (princ string)))
+ (in #'(lambda (string)
+ (princ ",\n\t\t\t\t ")
+ (princ string)))
(syntax-string (syntax-code-to-string code)))
(if (consp code)
(setq code (car code)))
(if (null syntax-string)
- (princ invalid)
+ (princ invalid)
(princ syntax-string)
(princ "\tmeaning: ")
(princ (aref ["whitespace" "punctuation" "word-constituent"
(bind-apollo-mouse-button "M1D" 'apollo-mouse-move-point
'apollo-mouse-move-point) ;MOUSE LEFT DOWN
(bind-apollo-mouse-button "M1U" 'apollo-mouse-move-mark
- 'apollo-mouse-copy) ;MOUSE LEFT UP
+ 'apollo-mouse-copy) ;MOUSE LEFT UP
(bind-apollo-mouse-button "M2D" 'sm-depress
'sm-depress-meta) ;MOUSE MIDDLE DOWN
(bind-apollo-mouse-button "M2U" 'smart-key-mouse
;; country code.
(let* ((i 128)
(modify (function
- (lambda (ch sy)
+ (lambda (ch sy)
(modify-syntax-entry ch sy text-mode-syntax-table)
(if-boundp 'tex-mode-syntax-table
(modify-syntax-entry ch sy tex-mode-syntax-table))
(define-key function-key-map "\eOP" [kp-numlock])
;;; linux.el ends here
-
* One of these atoms specifies the active region of the definition.
text, scrollbar, modeline, minibuffer
* One or two or these atoms specify the button or button combination.
- left, middle, right, double
+ left, middle, right, double
* Any combination of these atoms specify the active shift keys.
- control, shift, meta
+ control, shift, meta
* With a single unshifted button, you can add
up
to indicate an up-click.
L scroll-up line to top execute-extended-command
C proportional goto-char line to middle mouse-help
R scroll-down line to bottom eval-expression"
-
+
(interactive)
(let*
;; expect a string of <esc>:<buttons>;<x-pos>;<y-pos>c
((= buttons mouse-left)
(call-interactively 'execute-extended-command))
((= buttons mouse-center)
- (describe-function 'sup-mouse-report)); silly self help
+ (describe-function 'sup-mouse-report)); silly self help
))
(t ;in another window
(select-window window)
With a positive argument, select alternate keypad mode.
With a negative argument, select numeric keypad mode."
(interactive "P")
- (setq tvi970-keypad-numeric
+ (setq tvi970-keypad-numeric
(if (null arg)
(not tvi970-keypad-numeric)
(> (prefix-numeric-value arg) 0)))
With positive argument, switch to 132-column mode.
With negative argument, switch to 80-column mode."
(interactive "P")
- (setq vt100-wide-mode
+ (setq vt100-wide-mode
(if (null arg) (not vt100-wide-mode)
(> (prefix-numeric-value arg) 0)))
(send-string-to-terminal (if vt100-wide-mode "\e[?3h" "\e[?3l"))
;; Make F11 an escape key.
(define-key function-key-map "\e[23~" [?\e])
-
;; Make F11 an escape key.
(define-key function-key-map "\e[23~" [?\e])
-
(delete-horizontal-space)
(setq line-length (current-column))
(if (> (- fill-column lm line-length) 0)
- (indent-line-to
+ (indent-line-to
(+ lm (/ (- fill-column lm line-length) 2))))))
(cond ((null nlines)
(setq nlines 0))
(defcustom toolbar-open-function 'find-file
"*Function to call when the open icon is selected."
:type '(radio (function-item find-file)
- (function :tag "Other"))
+ (function :tag "Other"))
:group 'toolbar)
(defun toolbar-open ()
(defcustom toolbar-dired-function 'dired
"*Function to call when the dired icon is selected."
:type '(radio (function-item dired)
- (function :tag "Other"))
+ (function :tag "Other"))
:group 'toolbar)
(defun toolbar-dired (dir)
(defcustom toolbar-save-function 'save-buffer
"*Function to call when the save icon is selected."
:type '(radio (function-item save-buffer)
- (function :tag "Other"))
+ (function :tag "Other"))
:group 'toolbar)
(defun toolbar-save ()
(defcustom toolbar-print-function 'lpr-buffer
"*Function to call when the print icon is selected."
:type '(radio (function-item lpr-buffer)
- (function :tag "Other"))
+ (function :tag "Other"))
:group 'toolbar)
(defun toolbar-print ()
(defcustom toolbar-cut-function 'kill-primary-selection
"*Function to call when the cut icon is selected."
:type '(radio (function-item kill-primary-selection)
- (function :tag "Other"))
+ (function :tag "Other"))
:group 'toolbar)
(defun toolbar-cut ()
(defcustom toolbar-copy-function 'copy-primary-selection
"*Function to call when the copy icon is selected."
:type '(radio (function-item copy-primary-selection)
- (function :tag "Other"))
+ (function :tag "Other"))
:group 'toolbar)
(defun toolbar-copy ()
(defcustom toolbar-paste-function 'yank-clipboard-selection
"*Function to call when the paste icon is selected."
:type '(radio (function-item yank-clipboard-selection)
- (function :tag "Other"))
+ (function :tag "Other"))
:group 'toolbar)
(defun toolbar-paste ()
(defcustom toolbar-undo-function 'undo
"*Function to call when the undo icon is selected."
:type '(radio (function-item undo)
- (function :tag "Other"))
+ (function :tag "Other"))
:group 'toolbar)
(defun toolbar-undo ()
(defcustom toolbar-replace-function 'query-replace
"*Function to call when the replace icon is selected."
:type '(radio (function-item query-replace)
- (function :tag "Other"))
+ (function :tag "Other"))
:group 'toolbar)
(defun toolbar-replace ()
(const vm) (const gnus) (const rmail) (const mh)
(const pine) (const elm) (const mutt) (const exmh)
(const netscape)
- (const send)
+ (const send)
(symbol :tag "Other"
:validate (lambda (wid)
(if (assq (widget-value wid)
;; do this now because errors will occur if the icon symbols
;; are not initted
(set-specifier default-toolbar initial-toolbar-spec))
-
+
(defun toolbar-add-item-data ( icon-list &optional icon-dir )
(if (eq icon-dir nil)
(setq icon-dir toolbar-icon-directory))
(concat prefix "-xx.xbm"))))))
icon-list))
-(defvar toolbar-vector-open
+(defvar toolbar-vector-open
[toolbar-file-icon toolbar-open t "Open a file"]
"Define the vector for the \"Open\" toolbar button")
"Define the vector for the \"Spell\" toolbar button")
(defvar toolbar-vector-replace
- [toolbar-replace-icon toolbar-replace t "Search & Replace"]
+ [toolbar-replace-icon toolbar-replace t "Search & Replace"]
"Define the vector for the \"Replace\" toolbar button")
(defvar toolbar-vector-mail
(defvar tty-win-initted nil)
(defun tty-color-list (&optional registered-only)
- "Returns the list of colors the tty can handle. Since the tty will do color
+ "Returns the list of colors the tty can handle. Since the tty will do color
approximation, it will return all colors.
-When argument REGISTERED-ONLY is t `tty-color-list' will return only the
+When argument REGISTERED-ONLY is t `tty-color-list' will return only the
registered colors of the terminal."
(if registered-only
(tty-registered-color-list)
- (nconc (tty-registered-color-list)
+ (nconc (tty-registered-color-list)
(x-color-list))))
(defun init-tty-win ()
;; We descend recursively
(let ((dirs (directory-files dir t nil t 'subdir))
- dir)
+ dir)
(while (setq dir (pop dirs))
- (when (and (not (member (file-name-nondirectory dir)
+ (when (and (not (member (file-name-nondirectory dir)
update-elc-ignored-dirs))
- (file-directory-p dir))
- (do-update-elc-2 dir compile-stage-p seen))))
+ (file-directory-p dir))
+ (do-update-elc-2 dir compile-stage-p seen))))
)))
(load "dump-paths.el")
(let ((autol (packages-list-autoloads
- (if (getenv "BUILD_TREE_ROOT")
- (expand-file-name "lisp" (getenv "BUILD_TREE_ROOT"))
- (concat default-directory "../lisp")))))
+ (if (getenv "BUILD_TREE_ROOT")
+ (expand-file-name "lisp" (getenv "BUILD_TREE_ROOT"))
+ (concat default-directory "../lisp")))))
;;(print (prin1-to-string autol))
(while autol
(let (preloaded-file-list site-load-packages need-to-dump dumped-exe)
(load (if (getenv "SOURCE_TREE_ROOT")
- (expand-file-name "lisp/dumped-lisp.el" (getenv "SOURCE_TREE_ROOT"))
- (concat default-directory "../lisp/dumped-lisp.el")))
+ (expand-file-name "lisp/dumped-lisp.el" (getenv "SOURCE_TREE_ROOT"))
+ (concat default-directory "../lisp/dumped-lisp.el")))
(setq dumped-exe
(cond ((file-exists-p "../src/sxemacs") "../src/sxemacs")
;; Path setup
(let ((package-preloaded-file-list
(packages-collect-package-dumped-lisps late-package-load-path)))
-
+
(setq preloaded-file-list
- (append package-preloaded-file-list
- preloaded-file-list
+ (append package-preloaded-file-list
+ preloaded-file-list
'("bytecomp")
- packages-hardcoded-lisp)))
+ packages-hardcoded-lisp)))
(load (concat default-directory "../site-packages") t t)
(setq preloaded-file-list
arg)))
(when (and dumped-exe
(or (let ((frobel
- (if (getenv "SOURCE_TREE_ROOT")
- (expand-file-name
- (concat "lisp/" frob ".el")
- (getenv "SOURCE_TREE_ROOT"))
- (concat "../lisp/" frob ".el"))))
- (and (file-exists-p frobel)
- (file-newer-than-file-p frobel dumped-exe)))
- (let ((frobelc
- (if (getenv "BUILD_TREE_ROOT")
- (expand-file-name
- (concat "lisp/" frob ".elc")
- (getenv "BUILD_TREE_ROOT"))
- (concat "../lisp/" frob ".elc"))))
- (and (file-exists-p frobelc)
- (file-newer-than-file-p frobelc dumped-exe)))))
+ (if (getenv "SOURCE_TREE_ROOT")
+ (expand-file-name
+ (concat "lisp/" frob ".el")
+ (getenv "SOURCE_TREE_ROOT"))
+ (concat "../lisp/" frob ".el"))))
+ (and (file-exists-p frobel)
+ (file-newer-than-file-p frobel dumped-exe)))
+ (let ((frobelc
+ (if (getenv "BUILD_TREE_ROOT")
+ (expand-file-name
+ (concat "lisp/" frob ".elc")
+ (getenv "BUILD_TREE_ROOT"))
+ (concat "../lisp/" frob ".elc"))))
+ (and (file-exists-p frobelc)
+ (file-newer-than-file-p frobelc dumped-exe)))))
(setq need-to-dump t)))
; (if (null (member (file-name-nondirectory arg)
(let ((tem (let ((inhibit-quit t)
(cursor-in-echo-area t))
(prog1 (downcase (read-char))
- (setq quit-flag nil)))))
+ (setq quit-flag nil)))))
(if (= tem help-char)
(ask-user-about-lock-help)
(setq answer (assoc tem '((?s . t)
(let (answer)
(while (null answer)
(message "%s changed on disk; really edit the buffer? (y, n, r or C-h) "
- (file-name-nondirectory filename))
+ (file-name-nondirectory filename))
(let ((tem (downcase (let ((cursor-in-echo-area t))
(read-char)))))
(setq answer
(signal 'file-supersession
(list "File changed on disk" filename))))))
(message
- "File on disk now will become a backup file if you save these changes.")
+ "File on disk now will become a backup file if you save these changes.")
(setq buffer-backed-up nil))))
(defun ask-user-about-supersession-help ()
;; + (or (string-match "\\([0-9]+\\)\\.\\([0-9]+\\)" emacs-version)
;; (error "dired does not work with emacs version %s" emacs-version))
;; (setq ver (string-to-int (substring emacs-version (match-beginning 1)
-;; (match-end 1)))
+;; (match-end 1)))
;; @@ -6617,7 +6617,7 @@
-;;
+;;
;; (let ((lucid-p (string-match "XEmacs" emacs-version))
;; ver)
;; - (or (string-match "^\\([0-9]+\\)\\." emacs-version)
;; + (or (string-match "\\([0-9]+\\)\\." emacs-version)
;; (error "Weird emacs version %s" emacs-version))
;; (setq ver (string-to-int (substring emacs-version (match-beginning 1)
-;; (match-end 1))))
+;; (match-end 1))))
(if (featurep 'infodock)
(require 'id-vers))
(interactive "p")
(save-match-data
(let ((version-string
- (format
+ (format
"SXEmacs: %s, built %s on %s"
sxemacs-git-version
emacs-build-time
(defvar widget-browse-mode-map nil
"Keymap for `widget-browse-mode'.")
-
+
(unless widget-browse-mode-map
(setq widget-browse-mode-map (make-sparse-keymap))
(set-keymap-parent widget-browse-mode-map widget-keymap)
(define-key widget-browse-mode-map "q" 'bury-buffer))
-(easy-menu-define widget-browse-mode-customize-menu
+(easy-menu-define widget-browse-mode-customize-menu
widget-browse-mode-map
"Menu used in widget browser buffers."
(customize-menu-create 'widgets))
-(easy-menu-define widget-browse-mode-menu
+(easy-menu-define widget-browse-mode-menu
widget-browse-mode-map
"Menu used in widget browser buffers."
'("Widget"
;;;###autoload
(defun widget-browse (widget)
"Create a widget browser for WIDGET."
- (interactive (list (completing-read "Widget: "
+ (interactive (list (completing-read "Widget: "
obarray
(lambda (symbol)
(get symbol 'widget-type))
(kill-buffer (get-buffer-create "*Browse Widget*"))
(switch-to-buffer (get-buffer-create "*Browse Widget*")))
(widget-browse-mode)
-
+
;; Quick way to get out.
;; (widget-create 'push-button
;; :action (lambda (widget &optional event)
:action 'widget-browse-action)
(defun widget-browse-action (widget &optional event)
- ;; Create widget browser for WIDGET's :value.
+ ;; Create widget browser for WIDGET's :value.
(widget-browse (widget-get widget :value)))
(defun widget-browse-value-create (widget)
(add-to-list 'minor-mode-alist '(widget-minor-mode " Widget"))
-(add-to-list 'minor-mode-map-alist
+(add-to-list 'minor-mode-map-alist
(cons 'widget-minor-mode widget-minor-mode-map))
;;; The End:
(mouse-set-point event)
(let ((pos (event-point event)))
(if (and pos (get-char-property pos 'button))
- (widget-button-click event))))
+ (widget-button-click event))))
\f
;;; Widget text specifications.
;;
(when secret
(let ((begin (widget-field-start field))
(end (widget-field-end field)))
- (when size
+ (when size
(while (and (> end begin)
(eq (char-after (1- end)) ?\ ))
(setq end (1- end))))
(defun widget-specify-active (widget)
"Make WIDGET active for user modifications."
(let ((inactive (widget-get widget :inactive))
- (from (widget-get widget :from))
- (to (widget-get widget :to)))
+ (from (widget-get widget :from))
+ (to (widget-get widget :to)))
(when (and inactive (not (extent-detached-p inactive)))
;; Reactivate the buttons and fields covered by the extent.
(map-extents 'widget-activation-widget-mapper
- nil from to :activate nil 'button-or-field)
+ nil from to :activate nil 'button-or-field)
;; Reactivate the glyphs.
(map-extents 'widget-activation-glyph-mapper
- nil from to :activate nil 'end-glyph)
+ nil from to :activate nil 'end-glyph)
(delete-extent inactive)
(widget-put widget :inactive nil))))
;; of the widget type by `widget-prompt-value'.
(unless prompt
(setq prompt (or (and (widget-get widget :tag)
- (replace-in-string (widget-get widget :tag)
- "^[ \t]+" "" t))
- default-prompt
- "Value")))
+ (replace-in-string (widget-get widget :tag)
+ "^[ \t]+" "" t))
+ default-prompt
+ "Value")))
(widget-prompt-spaceify prompt))
;;;###autoload
(setq widget (widget-convert widget))
(let ((answer (widget-apply widget
:prompt-value
- (format "%s[%s]"
- (widget-prompt widget prompt)
- (widget-type widget))
- value unbound)))
+ (format "%s[%s]"
+ (widget-prompt widget prompt)
+ (widget-type widget))
+ value unbound)))
(while (not (widget-apply widget :match answer))
(setq answer (signal 'error (list "Answer does not match type"
answer (widget-type widget)))))
(lambda () ;?\]
(setq button-end (point-marker))
(set-marker-insertion-type button-end nil))
- (lambda () ;?\{
+ (lambda () ;?\{
(setq sample-begin (point)))
(lambda () ;?\}
(setq sample-end (point)))
- (lambda () ;?n
+ (lambda () ;?n
(when (widget-get widget :indent)
(insert ?\n)
(insert-char ?\ (widget-get widget :indent))))
(defun widget-checklist-prompt-value (widget prompt value unbound)
;; Prompt for items to be selected, and the prompt for their value
(let* ((args (widget-get widget :args))
- (choices (mapcar (lambda (elt)
- (cons (widget-get elt :tag) elt))
- args))
- (continue t)
- value)
+ (choices (mapcar (lambda (elt)
+ (cons (widget-get elt :tag) elt))
+ args))
+ (continue t)
+ value)
(while continue
(setq continue (completing-read
- (concat (widget-prompt-spaceify prompt)
- "select [ret. when done]: ")
- choices nil t))
+ (concat (widget-prompt-spaceify prompt)
+ "select [ret. when done]: ")
+ choices nil t))
(if (string= continue "")
- (setq continue nil)
- (push (widget-prompt-value (cdr (assoc continue choices))
- prompt nil t)
- value)))
+ (setq continue nil)
+ (push (widget-prompt-value (cdr (assoc continue choices))
+ prompt nil t)
+ value)))
(nreverse value)))
(defun widget-checklist-validate (widget)
(widget-apply
widget :value-to-external
(if unbound
- (mapcar #'(lambda (arg)
- (widget-prompt-value
- arg
- (concat (widget-prompt-spaceify prompt)
- (widget-prompt arg nil ""))
- nil t))
- args)
+ (mapcar #'(lambda (arg)
+ (widget-prompt-value
+ arg
+ (concat (widget-prompt-spaceify prompt)
+ (widget-prompt arg nil ""))
+ nil t))
+ args)
;; If VALUE is bound, the situation is a bit more complex because we
;; have to split it into a list of default values for every child. Oh,
;; boy, do I miss 'cl here... -- dvl
(let ((children args)
- (defaults (widget-apply widget
+ (defaults (widget-apply widget
:value-to-internal value))
- child default result)
- (while (setq child (pop children))
- (setq default (pop defaults))
- (push
- (widget-prompt-value
- child
- (concat (widget-prompt-spaceify prompt)
- (widget-prompt child nil ""))
- default) result))
- (nreverse result))))))
+ child default result)
+ (while (setq child (pop children))
+ (setq default (pop defaults))
+ (push
+ (widget-prompt-value
+ child
+ (concat (widget-prompt-spaceify prompt)
+ (widget-prompt child nil ""))
+ default) result))
+ (nreverse result))))))
(defun widget-group-match (widget values)
;; Match if the components match.
;; If VALUE is invalid (it doesn't match any choice), discard it by
;; considering it unbound:
(unless old
- (setq unbound t)))
+ (setq unbound t)))
;; Now offer the choice, providing the given default value when/where
;; appropriate:
(while args
current)
choices)))
(setq current
- (let ((val (completing-read (concat prompt ": ") choices nil t
- (when old
- (widget-apply old :menu-tag-get)))))
- (if (stringp val) ;; #### is this really needed ? --dvl
+ (let ((val (completing-read (concat prompt ": ") choices nil t
+ (when old
+ (widget-apply old :menu-tag-get)))))
+ (if (stringp val) ;; #### is this really needed ? --dvl
(let ((try (try-completion val choices)))
(when (stringp try) ;; #### and this ? --dvl
(setq val try))
(cdr (assoc val choices)))
nil)))
(if current
- (widget-prompt-value current
- (concat (widget-prompt-spaceify prompt)
- (widget-get current :tag))
- (unless unbound
- (when (eq current old) value))
- (or unbound (not (eq current old))))
+ (widget-prompt-value current
+ (concat (widget-prompt-spaceify prompt)
+ (widget-get current :tag))
+ (unless unbound
+ (when (eq current old) value))
+ (or unbound (not (eq current old))))
(and (not unbound) value))))
(define-widget 'radio 'radio-button-choice
nil, or a cons-cell containing a sexp and my-lisp. This will not work
because the `choice' widget does not allow recursion.
-Using the `lazy' widget you can overcome this problem, as in this
-example:
+Using the `lazy' widget you can overcome this problem, as in this
+example:
(define-widget 'sexp-list 'lazy
\"A list of sexps.\"
:format "%{%t%}: %v"
;; We don't convert :type because we want to allow recursive
;; datastructures. This is slow, so we should not create speed
- ;; critical widgets by deriving from this.
+ ;; critical widgets by deriving from this.
:convert-widget 'widget-value-convert-widget
:value-create 'widget-type-value-create
:value-delete 'widget-children-value-delete
The value of the :type attribute should be an unconverted widget type."
(let ((value (widget-get widget :value))
(type (widget-get widget :type)))
- (widget-put widget :children
- (list (widget-create-child-value widget
- (widget-convert type)
- value)))))
+ (widget-put widget :children
+ (list (widget-create-child-value widget
+ (widget-convert type)
+ value)))))
(defun widget-type-default-get (widget)
"Get default value from the :type attribute of WIDGET.
2)
(window-height upper))
nil upper))
- ;; Klaus Berndl <klaus.berndl@sdm.de>: Only in
- ;; this situation we shrink-to-fit but we can do
- ;; this first after we have displayed buffer in
- ;; window (s.b. (set-window-buffer window buffer))
- (setq shrink-it shrink-to-fit))))
+ ;; Klaus Berndl <klaus.berndl@sdm.de>: Only in
+ ;; this situation we shrink-to-fit but we can do
+ ;; this first after we have displayed buffer in
+ ;; window (s.b. (set-window-buffer window buffer))
+ (setq shrink-it shrink-to-fit))))
(setq window (get-lru-window target-frame)))
(set-window-buffer window buffer)
- ;; Now window's previous buffer has been brought to the top
- ;; of the MRU chain and window displays buffer - now we can
- ;; shrink-to-fit if necessary
- (if shrink-it
- (shrink-window-if-larger-than-buffer window))
+ ;; Now window's previous buffer has been brought to the top
+ ;; of the MRU chain and window displays buffer - now we can
+ ;; shrink-to-fit if necessary
+ (if shrink-it
+ (shrink-window-if-larger-than-buffer window))
(display-buffer-1 window)))))
(or (equal wconfig (current-window-configuration))
"Make all visible windows the same height (approximately)."
(interactive)
(let ((count -1) levels newsizes size)
- ;FSFmacs
+ ;FSFmacs
;;; Don't count the lines that are above the uppermost windows.
;;; (These are the menu bar lines, if any.)
;(mbl (nth 1 (window-edges (frame-first-window (selected-frame))))))
(save-window-excursion
(let (tops (prev-top -2))
(walk-windows (function (lambda (w)
- (setq tops (cons (nth 1 (window-pixel-edges w))
- tops))))
+ (setq tops (cons (nth 1 (window-pixel-edges w))
+ tops))))
'nomini)
(setq tops (sort tops '<))
(while tops
(setq size (/ (window-pixel-height (frame-root-window)) count))
(walk-windows (function
(lambda (w)
- (select-window w)
- (let ((newtop (cdr (assq (nth 1 (window-pixel-edges))
- levels)))
- (newbot (or (cdr (assq
+ (select-window w)
+ (let ((newtop (cdr (assq (nth 1 (window-pixel-edges))
+ levels)))
+ (newbot (or (cdr (assq
(+ (window-pixel-height)
(nth 1 (window-pixel-edges)))
levels))
- count)))
- (setq newsizes
- (cons (cons w (* size (- newbot newtop)))
- newsizes)))))
+ count)))
+ (setq newsizes
+ (cons (cons w (* size (- newbot newtop)))
+ newsizes)))))
'nomini)
(walk-windows (function (lambda (w)
(select-window w)
(enlarge-window
(/ (- newsize (window-pixel-height))
(face-height 'default))))))
- 'nomini)))
+ 'nomini)))
\f
;;; I think this should be the default; I think people will prefer it--rms.
(defcustom split-window-keep-point t
Any other non-nil value means search all devices."
(let ((wins nil))
(walk-windows (lambda (win)
- (push win wins))
- minibuf which-frames which-devices)
+ (push win wins))
+ minibuf which-frames which-devices)
wins))
;;; window.el ends here
(defun x-read-color-completion-table ()
"Color table for interactive completion"
- (unless (and (skiplistp x-color-slist)
+ (unless (and (skiplistp x-color-slist)
(> (skiplist-size x-color-slist) 0))
(x-color-read-system-colors))
(let ((res))
- (map-skiplist #'(lambda (key val)
- (setq res (nconc res (list (list (format "%s" key))))))
+ (map-skiplist #'(lambda (key val)
+ (setq res (nconc res (list (list (format "%s" key))))))
x-color-slist)
res))
(defun x-color-list ()
"Color list"
- (unless (and (skiplistp x-color-slist)
+ (unless (and (skiplistp x-color-slist)
(> (skiplist-size x-color-slist) 0))
(x-color-read-system-colors))
(let ((res))
- (map-skiplist #'(lambda (key val)
+ (map-skiplist #'(lambda (key val)
(setq res (nconc res (list (format "%s" key)))))
x-color-slist)
res))
"Retrieve the color by NAME"
(interactive)
(x-color-rgb-components name))
-
+
(defun x-find-color-rgb (name &optional nearest)
"Retrieve the color by NAME"
- (unless (or (symbolp name)
+ (unless (or (symbolp name)
(stringp name)
(x-rgb-color-p name))
(error 'wrong-type-argument name))
- (unless (and (skiplistp x-color-slist)
+ (unless (and (skiplistp x-color-slist)
(> (skiplist-size x-color-slist) 0))
(x-color-read-system-colors))
(if (x-rgb-color-p name)
(color-sym (intern color-name))
(color-lc-sym (intern (downcase color-name)))
(color-ns-sym (intern (replace-in-string color-name " " "")))
- (color-lcns-sym (intern (replace-in-string
+ (color-lcns-sym (intern (replace-in-string
(downcase color-name)
" " ""))))
(or (get-skiplist x-color-slist color-sym)
"Parse RGB color specification and return a list of integers (R G B).
#FEFEFE and rgb:fe/fe/fe style specifications are parsed.
Returns NIL if RGB color specification is invalid."
- (let ((case-fold-search t)
+ (let ((case-fold-search t)
matches)
- (if (string-match #r"\([0-9.]+\)\s-+\([0-9.]+\)\s-+\([0-9.]+\)"
+ (if (string-match #r"\([0-9.]+\)\s-+\([0-9.]+\)\s-+\([0-9.]+\)"
color)
;; recurse and parse hexadecimal color
- (x-color-parse-rgb-components
- (apply 'format "#%02X%02X%02X"
+ (x-color-parse-rgb-components
+ (apply 'format "#%02X%02X%02X"
(mapcar #'(lambda (c) (if (floatp c) c (* 255 c)))
(mapcar #'(lambda (i)
- (let ((m
- (string-to-number
+ (let ((m
+ (string-to-number
(match-string i color))))
(if (<= 0 m 1)
(* 255 m)
(setq matches (mapcar #'(lambda (i) (match-string i color))
'(1 2 3)))
;; Make sure all components have at most 4 hex digits
- (when (eval
+ (when (eval
(append '(and)
(mapcar #'(lambda (component)
(> 5 (length component) 0))
into their components.
RGB values for color names are looked up using 'x-find-color-rgb'."
(let ((case-fold-search t)
- (color-rgb
+ (color-rgb
(cond ((x-rgb-color-p color)
(mapcar #'(lambda (f)
(funcall f color))
(= 3 (length color)))
color))))
(cond ((and color-rgb
- (eval (append '(and)
- (mapcar #'(lambda (c)
+ (eval (append '(and)
+ (mapcar #'(lambda (c)
(and (numberp c) (<= 0 c 1)))
color))))
(mapcar #'(lambda (c) (* 65535 c)) color))
((and color-rgb
- (eval (append '(and)
- (mapcar #'(lambda (c)
+ (eval (append '(and)
+ (mapcar #'(lambda (c)
(and (numberp c) (<= 0 c 255)))
color))))
(mapcar #'(lambda (c) (lsh c 8)) color))
((and color-rgb
- (eval (append '(or)
- (mapcar #'(lambda (c)
+ (eval (append '(or)
+ (mapcar #'(lambda (c)
(and (numberp c) (<= 0 c 65535)))
color))))
color)
(defun x-read-rgb-file (filename)
"Read the colors from FILENAME. The file is expected to have the same
format as X11 rgb.txt"
- (let ((rgb-regex
+ (let ((rgb-regex
#r"^\s-*\([0-9]+\)\s-+\([0-9]+\)\s-+\([0-9]+\)\s-+\([a-zA-Z0-9 ]+\)\s-*$"))
(unless (skiplistp x-color-slist)
(setq x-color-slist (make-skiplist)))
(widen)
(goto-char (point-min))
(while (re-search-forward rgb-regex nil t)
- (let ((rgb-matches
- (mapcar #'(lambda (i)
+ (let ((rgb-matches
+ (mapcar #'(lambda (i)
(lsh (read (match-string i)) 8))
'(1 2 3)))
(color-name (match-string 4)))
(mapc #'(lambda (name)
(put-skiplist x-color-slist
- (intern name)
+ (intern name)
rgb-matches))
- (list color-name
+ (list color-name
(downcase color-name)
(replace-in-string color-name " " "")
- (replace-in-string (downcase color-name)
+ (replace-in-string (downcase color-name)
" " "")))))))))))
-
+
(defun x-color-read-system-colors ()
"Read the system colors"
(when (locate-data-file "rgb.txt")
(dB (- (caddr color1) (caddr color2))))
(+ (* dR dR) (* dG dG) (* dB dB)))))
-
+
(defsubst x-color-distance-1 (color1 color2)
"Return the color cube distance between the two colors.
Assumes COLOR1 is an 8 bit rgb tupple. "
(defvar x-nearest-color-favor-non-gray-threshold 0.065
"If the approximated color is not close enough to the
-gray diagonal of the RGB cube, favor non-gray colors.
+gray diagonal of the RGB cube, favor non-gray colors.
The default number 0.065 is an empirical ad-hoc'ery")
(defun x-nearest-color (color &optional colorlist) "
COLOR can be a color name, an '(r g b) tuple or a color specification.
#FEFEFE and rgb:fe/fe/fe style specifications are parsed.
COLORLIST is a list of colors in the same acceptable formats as COLOR.
-Returns NIL if color specification is invalid, or no colors
+Returns NIL if color specification is invalid, or no colors
close enough are found."
(let (color-rgb)
(when (or (stringp color) (symbolp color))
(setq color-rgb (x-rgb-to-8bits (find-color-rgb color))))
(when (not color-rgb)
(error 'invalid-argument color))
- (let ((favor-non-gray (>= (apply 'x-color-off-gray-diag color-rgb)
+ (let ((favor-non-gray (>= (apply 'x-color-off-gray-diag color-rgb)
x-nearest-color-favor-non-gray-threshold))
(best-distance 195076) ;; Max possible distance: 3 * 255^2 + 15
best-color)
(< distance best-distance)
;; The candidate color is on the gray diagonal
;; if its RGB components are all equal.
- (or (/= (x-rgb-color-red cand-rgb)
- (x-rgb-color-green cand-rgb))
+ (or (/= (x-rgb-color-red cand-rgb)
+ (x-rgb-color-green cand-rgb))
(/= (x-rgb-color-green cand-rgb)
(x-rgb-color-blue cand-rgb))
(not favor-non-gray)))
;;; Regexps matching font names in "Host Portable Character Representation."
;;;
-(let ((- "[-?]")
+(let ((- "[-?]")
(foundry "[^-]*")
- (family "[^-]*")
+ (family "[^-]*")
(weight #r"\(bold\|demibold\|medium\|black\)") ; 1
; (weight\? "\\(\\*\\|bold\\|demibold\\|medium\\|\\)") ; 1
(weight\? #r"\([^-]*\)") ; 1
This is run the first time that a font-menu is needed for each device.
If you don't like the lazy invocation of this function, you can add it to
`create-device-hook' and that will make the font menus respond more quickly
-when they are selected for the first time. If you add fonts to your system,
+when they are selected for the first time. If you add fonts to your system,
or if you change your font path, you can call this to re-initialize the menus."
;; by Stig@hackvan.com
;; #### - this should implement a `menus-only' option, which would
(setq sizes (cons (car common) sizes)))
(setq common (cdr common)))
(setq sizes (delq 0 sizes))))
-
+
(setq families (sort families 'string-lessp)
weights (sort weights 'string-lessp)
sizes (sort sizes '<))
-
+
(dolist (entry cache)
(aset entry 1 (sort (aref entry 1) 'string-lessp))
(aset entry 2 (sort (aref entry 2) '<)))
(setq entry (vassoc family (aref dcache 0))))
(when (null entry)
(return-from x-font-menu-font-data (make-vector 5 nil)))
-
+
(when (string-match x-font-regexp name)
(setq weight (capitalize (match-string 1 name)))
(setq size (string-to-int (match-string 6 name))))
-
+
(when (string-match x-font-regexp truename)
(when (not (member weight (aref entry 1)))
(setq weight (capitalize (match-string 1 truename))))
(when (not (member size (aref entry 2)))
(setq size (string-to-int (match-string 6 truename))))
(setq slant (capitalize (match-string 2 truename))))
-
+
(vector entry family size weight slant)))
(defun x-font-menu-load-font (family weight size slant resolution)
;; is managing, so assume all MIT displays are Suns... HA HA!
(string-equal "MIT X Consortium" vendor)
(string-equal "X Consortium" vendor))
- ;; Ok, we think this could be a Sun keyboard. Run the Sun code.
+ ;; Ok, we think this could be a Sun keyboard. Run the Sun code.
(x-win-init-sun))
- ((string-match "XFree86" vendor)
- ;; Those XFree86 people do some weird keysym stuff, too.
+ ((string-match "XFree86" vendor)
+ ;; Those XFree86 people do some weird keysym stuff, too.
(x-win-init-xfree86)))))
\f
(setq character-set-property 'x-iso8859/1) ; see x-iso8859-1.el
(setq initial-frame-plist (if initial-frame-unmapped-p
- '(initially-unmapped t)
- nil))
+ '(initially-unmapped t)
+ nil))
(setq pre-x-win-initted t)))
(defvar x-win-initted nil)
;; Open the X display when this file is loaded
;; (Note that the first frame is created later.)
(setq x-initial-argv-list (cons (car command-line-args)
- command-line-args-left))
+ command-line-args-left))
;; Locate the app-defaults directory
(when (and (boundp 'x-app-defaults-directory)
(null x-app-defaults-directory))
;; because the icon initialization needs to access the display to get
;; any toolbar-related color resources.
(if (and (not (featurep 'infodock)) (featurep 'toolbar))
- (init-x-toolbar))
+ (init-x-toolbar))
(if (and (featurep 'infodock) (featurep 'toolbar))
(require 'id-x-toolbar))
(if (featurep 'gutter) (init-gutter))
(defconst iso8859/1-code-to-x-keysym-table nil
"Maps iso8859/1 to an X keysym name which corresponds to it.
There may be more than one X name for this keycode; this returns the first one.
-Note that this is X specific; one should avoid using this table whenever
+Note that this is X specific; one should avoid using this table whenever
possible, in the interest of portability.")
;; (This esoteric little construct is how you do MACROLET in elisp. It
;;
;; First emit code that puts the `x-iso8859/1' property on all of
;; the keysym symbols.
- ;;
+ ;;
(mapcar '(lambda (sym-and-code)
(list 'put (list 'quote (car sym-and-code))
''x-iso8859/1 (car (cdr sym-and-code))))
;;
;; Then emit code that binds all of those keysym symbols to
;; `self-insert-command'.
- ;;
+ ;;
(mapcar '(lambda (sym-and-code)
(list 'global-set-key (list 'quote (car sym-and-code))
''self-insert-command))
(currency ?\244)
(yen ?\245)
(brokenbar ?\246)
- (section ?\247)
+ (section ?\247)
(diaeresis ?\250)
(copyright ?\251)
(ordfeminine ?\252)
(plusminus ?\261)
(twosuperior ?\262)
(threesuperior ?\263)
- (acute ?\264) ; Why is there an acute keysym that is
- (mu ?\265) ; distinct from apostrophe/quote, but
+ (acute ?\264) ; Why is there an acute keysym that is
+ (mu ?\265) ; distinct from apostrophe/quote, but
(paragraph ?\266) ; no grave keysym that is distinct from
- (periodcentered ?\267) ; backquote?
+ (periodcentered ?\267) ; backquote?
(cedilla ?\270) ; I've added the grave keysym, because it's
(onesuperior ?\271) ; used in x-compose (Heiko Muenkel).
(masculine ?\272)
(x-store-cutbuffer
(mapconcat
#'identity
- (declare-fboundp
+ (declare-fboundp
(extract-rectangle
(extent-start-position (car primary-selection-extent))
(extent-end-position (car (reverse primary-selection-extent)))))
(x-init-specifier-from-resources
(specifier-fallback scrollbar-width) 'natnum locale
'("scrollbar.width" . "ScrollBar.Width")))
-
+
;; lather, rinse, repeat.
(x-init-specifier-from-resources
(specifier-fallback scrollbar-height) 'natnum locale
projects / sxemacs / commitdiff