which included commits to RCS files with non-trunk default branches.
--x-includes=DIR Search for X header files in DIR.
--x-libraries=DIR Search for X libraries in DIR.
--without-toolbars Don't compile with any toolbar support.
---without-session Compile without realized leader window which will
- keep the WM_COMMAND property. Required for proper
- session-management.
+--without-wmcommand Compile without realized leader window which will
+ keep the WM_COMMAND property.
--with-menubars=TYPE Use TYPE menubars (lucid, motif, or no). The Lucid
widgets emulate Motif (mostly) but are faster.
*WARNING* The Motif menubar is currently broken.
* Mountain View, California 94043
*/
-#pragma ident "@(#) $Id: _dynodump.h,v 1.5 1996/05/23 18:39:07 georgn Exp $ - SMI"
+#pragma ident "@(#) $Id: _dynodump.h,v 1.3 1997/05/29 04:22:29 steve Exp $ - SMI"
#ifndef _DYNODUMP_DOT_H
#define _DYNODUMP_DOT_H
* N.B. The above commentary is not quite correct in the flags have been hardwired
* to RTLD_SAVREL.
*/
-#pragma ident "@(#) $Id: dynodump.c,v 1.8 1996/05/23 18:39:21 georgn Exp $ - SMI"
+#pragma ident "@(#) $Id: dynodump.c,v 1.6 1998/03/31 20:10:55 steve Exp $ - SMI"
#define __EXTENSIONS__ 1
* Mountain View, California 94043
*/
-#pragma ident "@(#) $Id: _relocate.c,v 1.4 1995/06/26 20:12:41 georgn Exp $ - SMI"
+#pragma ident "@(#) $Id: _relocate.c,v 1.3 1997/05/29 04:23:02 steve Exp $ - SMI"
/* LINTLIBRARY */
* Mountain View, California 94043
*/
-#pragma ident "@(#) $Id: machdep.h,v 1.2 1995/02/16 22:58:43 georgn Exp $ - SMI"
+#pragma ident "@(#) $Id: machdep.h,v 1.3 1997/05/29 04:23:02 steve Exp $ - SMI"
/*
* Global include file for all sgs Intel machine dependent macros, constants
* Mountain View, California 94043
*/
-#pragma ident "@(#) $Id: _relocate.c,v 1.3 1995/06/26 20:16:39 georgn Exp $ - SMI"
+#pragma ident "@(#) $Id: _relocate.c,v 1.4 1998/03/31 20:10:55 steve Exp $ - SMI"
/* LINTLIBRARY */
* Mountain View, California 94043
*/
-#pragma ident "@(#) $Id: machdep.h,v 1.2 1995/02/16 22:58:49 georgn Exp $ - SMI"
+#pragma ident "@(#) $Id: machdep.h,v 1.3 1997/05/29 04:23:20 steve Exp $ - SMI"
/*
* Global include file for all sgs PowerPC machine dependent macros, constants
/*
* Update the value of the `_edata' and `_end' symbols.
*/
-#pragma ident "@(#) $Id: _relocate.c,v 1.4 1995/06/26 20:13:26 georgn Exp $ - SMI"
+#pragma ident "@(#) $Id: _relocate.c,v 1.4 1998/03/31 20:10:55 steve Exp $ - SMI"
#include <libelf.h>
#include <string.h>
* Mountain View, California 94043
*/
-#pragma ident "@(#) $Id: machdep.h,v 1.2 1995/02/16 22:58:55 georgn Exp $ - SMI"
+#pragma ident "@(#) $Id: machdep.h,v 1.3 1997/05/29 04:23:26 steve Exp $ - SMI"
/*
* Global include file for all sgs SPARC machine dependent macros, constants
/*
* Update the value of the `_edata' and `_end' symbols.
*/
-#pragma ident "@(#) $Id: syms.c,v 1.2 1995/03/06 22:39:22 georgn Exp $ - SMI"
+#pragma ident "@(#) $Id: syms.c,v 1.3 1997/05/29 04:22:30 steve Exp $ - SMI"
#include <libelf.h>
#include <string.h>
`~hniksic/'. To make this operation faster, a cache of user names is
maintained internally.
+The new primitives available for this purpose are functions named
+`user-name-completion' and `user-name-all-completions'.
+
\f
* Lisp and internal changes in XEmacs 21.2
==========================================
Of course, the old form is still accepted for backward compatibility.
+** `translate-region' has been improved in several ways. Its TABLE
+argument used to be a 256-character string. In addition to this, it
+can now also be a vector or a char-table (which is useful for Mule.)
+If TABLE a vector or a generic char-table, you can map characters to
+strings instead of to other characters. For instance:
+
+ (let ((table (make-char-table 'generic)))
+ (put-char-table ?a "the letter a" table)
+ (put-char-table ?b "" table)
+ (put-char-table ?c ?\n table)
+ (translate-region (point-min) (point-max) table))
+
** The `keywordp' function now returns non-nil only on symbols
interned in the global obarray. For example:
This behaviour is compatible with other code which treats symbols
beginning with colon as keywords only if they are interned in the
-global obarray. `keyword' used to wrongly return t in both cases
+global obarray. `keywordp' used to wrongly return t in both cases
above.
** The first argument to `intern-soft' may now also be a symbol, like
* New-Users-Guide:: XEmacs New User's Guide for XEmacs 21.2.
* XEmacs-FAQ:: XEmacs Frequently Asked Questions for 21.2.
* Internals:: Guide to the internals of XEmacs.
+* Emodules:: XEmacs dynamic loadable module support.
Local Packages:
+1999-06-03 SL Baur <steve@steve1.m17n.org>
+
+ * Makefile.in.in: Move .PHONY up to force execution of `all'.
+
1999-05-14 XEmacs Build Bot <builds@cvs.xemacs.org>
* XEmacs 21.2.14 is released
.c.o:
${CC} -c $(cflags) $<
+.PHONY : all maybe-blessmail install uninstall
+
all: ${UTILITIES} ${INSTALLABLES} srcdir-symlink.stamp
## Make symlinks for shell scripts if using --srcdir
## We do not need to install "wakeup" explicitly, because it will be
## copied when this whole directory is copied.
-.PHONY : all maybe-blessmail install uninstall
install: ${archlibdir}
@echo; echo "Installing utilities for users to run."
for file in ${INSTALLABLES} ; do \
ETCDIR "@ETCDIR@"
ETCDIR_USER_DEFINED "@ETCDIR_USER_DEFINED@"
EXEC_PREFIX "@EXEC_PREFIX@"
+FFLAGS "@FFLAGS@"
INFODIR "@INFODIR@"
INFODIR_USER_DEFINED "@INFODIR_USER_DEFINED@"
INFOPATH "@INFOPATH@"
INSTALL_ARCH_DEP_SUBDIR "@INSTALL_ARCH_DEP_SUBDIR@"
INSTALL_DATA "@INSTALL_DATA@"
INSTALL_PROGRAM "@INSTALL_PROGRAM@"
+INSTALL_SCRIPT "@INSTALL_SCRIPT@"
LDFLAGS "@LDFLAGS@"
LIBS "@LIBS@"
LISPDIR "@LISPDIR@"
RANLIB "@RANLIB@"
RECURSIVE_MAKE "@RECURSIVE_MAKE@"
SET_MAKE "@SET_MAKE@"
+SHELL "@SHELL@"
SITELISPDIR "@SITELISPDIR@"
SITELISPDIR_USER_DEFINED "@SITELISPDIR_USER_DEFINED@"
SITEMODULEDIR "@SITEMODULEDIR@"
Report bugs to <bug-gnu-emacs@prep.ai.mit.edu>.'
-Id='$Id: rcs2log,v 1.37 1997/03/21 22:19:30 eggert Exp $'
+Id='$Id: rcs2log,v 1.2 1997/07/09 04:31:03 steve Exp $'
# Copyright 1992, 1993, 1994, 1995, 1996, 1997 Free Software Foundation, Inc.
;; This file is part of XEmacs.
-;; This file is very similar to mule-files.el
-
;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
+;;; Synched up with: Not synched.
+
;;; Commentary:
-;;; Derived from mule.el in the original Mule but heavily modified
-;;; by Ben Wing.
+;; Derived from mule.el in the original Mule but heavily modified
+;; by Ben Wing.
;; 1997/3/11 modified by MORIOKA Tomohiko to sync with Emacs 20 API.
+;; This file was derived from the former mule-files.el which has been removed
+;; as of XEmacs 21.2.15.
+
;;; Code:
(setq-default buffer-file-coding-system 'no-conversion)
start end filename append visit lockname
coding-system)))
-;;; mule-files.el ends here
+;;; The following was all that remained in mule-files.el, so I moved it
+;;; here for neatness. -sb
+(when (featurep 'mule)
+ (setq-default buffer-file-coding-system 'iso-2022-8))
+
+;;; code-files.el ends here
(not (eq Info-auto-advance t))
(not (eq last-command this-command)))
(message "Hit %s again to go to previous node"
- (if (= last-command-char 0)
+ (if (mouse-event-p last-command-event)
"mouse button"
- (key-description (char-to-string last-command-char))))
+ (key-description (event-key last-command-event))))
(Info-page-prev)
(setq this-command 'Info))
(scroll-down arg)))
;; Author: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch>
;; Maintainer: Oscar Figueiredo <Oscar.Figueiredo@di.epfl.ch>
;; Created: Jan 1998
-;; Version: $Revision: 1.7.2.3 $
+;; Version: $Revision: 1.7.2.5 $
;; Keywords: help comm
;; This file is part of XEmacs
(integer :tag "(number of records)")))))
:group 'ldap)
+(defcustom ldap-ignore-attribute-codings nil
+ "*If non-nil, do not perform any encoding/decoding on LDAP attribute values."
+ :type 'boolean
+ :group 'ldap)
+
+(defcustom ldap-default-attribute-decoder nil
+ "*Decoder function to use for attributes whose syntax is unknown."
+ :type 'symbol
+ :group 'ldap)
+
+(defcustom ldap-coding-system (if (featurep 'mule)
+ 'utf-8
+ nil)
+ "*Coding system of LDAP string values.
+LDAP v3 specifies the coding system of strings to be UTF-8.
+Mule support is needed for this."
+ :type 'symbol
+ :group 'ldap)
+
+(defvar ldap-attribute-syntax-encoders
+ [nil ; 1 ACI Item N
+ nil ; 2 Access Point Y
+ nil ; 3 Attribute Type Description Y
+ nil ; 4 Audio N
+ nil ; 5 Binary N
+ nil ; 6 Bit String Y
+ ldap-encode-boolean ; 7 Boolean Y
+ nil ; 8 Certificate N
+ nil ; 9 Certificate List N
+ nil ; 10 Certificate Pair N
+ ldap-encode-country-string ; 11 Country String Y
+ ldap-encode-string ; 12 DN Y
+ nil ; 13 Data Quality Syntax Y
+ nil ; 14 Delivery Method Y
+ ldap-encode-string ; 15 Directory String Y
+ nil ; 16 DIT Content Rule Description Y
+ nil ; 17 DIT Structure Rule Description Y
+ nil ; 18 DL Submit Permission Y
+ nil ; 19 DSA Quality Syntax Y
+ nil ; 20 DSE Type Y
+ nil ; 21 Enhanced Guide Y
+ nil ; 22 Facsimile Telephone Number Y
+ nil ; 23 Fax N
+ nil ; 24 Generalized Time Y
+ nil ; 25 Guide Y
+ nil ; 26 IA5 String Y
+ number-to-string ; 27 INTEGER Y
+ nil ; 28 JPEG N
+ nil ; 29 Master And Shadow Access Points Y
+ nil ; 30 Matching Rule Description Y
+ nil ; 31 Matching Rule Use Description Y
+ nil ; 32 Mail Preference Y
+ nil ; 33 MHS OR Address Y
+ nil ; 34 Name And Optional UID Y
+ nil ; 35 Name Form Description Y
+ nil ; 36 Numeric String Y
+ nil ; 37 Object Class Description Y
+ nil ; 38 OID Y
+ nil ; 39 Other Mailbox Y
+ nil ; 40 Octet String Y
+ ldap-encode-address ; 41 Postal Address Y
+ nil ; 42 Protocol Information Y
+ nil ; 43 Presentation Address Y
+ ldap-encode-string ; 44 Printable String Y
+ nil ; 45 Subtree Specification Y
+ nil ; 46 Supplier Information Y
+ nil ; 47 Supplier Or Consumer Y
+ nil ; 48 Supplier And Consumer Y
+ nil ; 49 Supported Algorithm N
+ nil ; 50 Telephone Number Y
+ nil ; 51 Teletex Terminal Identifier Y
+ nil ; 52 Telex Number Y
+ nil ; 53 UTC Time Y
+ nil ; 54 LDAP Syntax Description Y
+ nil ; 55 Modify Rights Y
+ nil ; 56 LDAP Schema Definition Y
+ nil ; 57 LDAP Schema Description Y
+ nil ; 58 Substring Assertion Y
+ ]
+ "A vector of functions used to encode LDAP attribute values.
+The sequence of functions corresponds to the sequence of LDAP attribute syntax
+object identifiers of the form 1.3.6.1.4.1.1466.1115.121.1.* as defined in
+RFC2252 section 4.3.2")
+
+(defvar ldap-attribute-syntax-decoders
+ [nil ; 1 ACI Item N
+ nil ; 2 Access Point Y
+ nil ; 3 Attribute Type Description Y
+ nil ; 4 Audio N
+ nil ; 5 Binary N
+ nil ; 6 Bit String Y
+ ldap-decode-boolean ; 7 Boolean Y
+ nil ; 8 Certificate N
+ nil ; 9 Certificate List N
+ nil ; 10 Certificate Pair N
+ ldap-decode-string ; 11 Country String Y
+ ldap-decode-string ; 12 DN Y
+ nil ; 13 Data Quality Syntax Y
+ nil ; 14 Delivery Method Y
+ ldap-decode-string ; 15 Directory String Y
+ nil ; 16 DIT Content Rule Description Y
+ nil ; 17 DIT Structure Rule Description Y
+ nil ; 18 DL Submit Permission Y
+ nil ; 19 DSA Quality Syntax Y
+ nil ; 20 DSE Type Y
+ nil ; 21 Enhanced Guide Y
+ nil ; 22 Facsimile Telephone Number Y
+ nil ; 23 Fax N
+ nil ; 24 Generalized Time Y
+ nil ; 25 Guide Y
+ nil ; 26 IA5 String Y
+ string-to-number ; 27 INTEGER Y
+ nil ; 28 JPEG N
+ nil ; 29 Master And Shadow Access Points Y
+ nil ; 30 Matching Rule Description Y
+ nil ; 31 Matching Rule Use Description Y
+ nil ; 32 Mail Preference Y
+ nil ; 33 MHS OR Address Y
+ nil ; 34 Name And Optional UID Y
+ nil ; 35 Name Form Description Y
+ nil ; 36 Numeric String Y
+ nil ; 37 Object Class Description Y
+ nil ; 38 OID Y
+ nil ; 39 Other Mailbox Y
+ nil ; 40 Octet String Y
+ ldap-decode-address ; 41 Postal Address Y
+ nil ; 42 Protocol Information Y
+ nil ; 43 Presentation Address Y
+ ldap-decode-string ; 44 Printable String Y
+ nil ; 45 Subtree Specification Y
+ nil ; 46 Supplier Information Y
+ nil ; 47 Supplier Or Consumer Y
+ nil ; 48 Supplier And Consumer Y
+ nil ; 49 Supported Algorithm N
+ nil ; 50 Telephone Number Y
+ nil ; 51 Teletex Terminal Identifier Y
+ nil ; 52 Telex Number Y
+ nil ; 53 UTC Time Y
+ nil ; 54 LDAP Syntax Description Y
+ nil ; 55 Modify Rights Y
+ nil ; 56 LDAP Schema Definition Y
+ nil ; 57 LDAP Schema Description Y
+ nil ; 58 Substring Assertion Y
+ ]
+ "A vector of functions used to decode LDAP attribute values.
+The sequence of functions corresponds to the sequence of LDAP attribute syntax
+object identifiers of the form 1.3.6.1.4.1.1466.1115.121.1.* as defined in
+RFC2252 section 4.3.2")
+
+
+(defvar ldap-attribute-syntaxes-alist
+ '((createtimestamp . 24)
+ (modifytimestamp . 24)
+ (creatorsname . 12)
+ (modifiersname . 12)
+ (subschemasubentry . 12)
+ (attributetypes . 3)
+ (objectclasses . 37)
+ (matchingrules . 30)
+ (matchingruleuse . 31)
+ (namingcontexts . 12)
+ (altserver . 26)
+ (supportedextension . 38)
+ (supportedcontrol . 38)
+ (supportedsaslmechanisms . 15)
+ (supportedldapversion . 27)
+ (ldapsyntaxes . 16)
+ (ditstructurerules . 17)
+ (nameforms . 35)
+ (ditcontentrules . 16)
+ (objectclass . 38)
+ (aliasedobjectname . 12)
+ (cn . 15)
+ (sn . 15)
+ (serialnumber . 44)
+ (c . 15)
+ (l . 15)
+ (st . 15)
+ (street . 15)
+ (o . 15)
+ (ou . 15)
+ (title . 15)
+ (description . 15)
+ (searchguide . 25)
+ (businesscategory . 15)
+ (postaladdress . 41)
+ (postalcode . 15)
+ (postofficebox . 15)
+ (physicaldeliveryofficename . 15)
+ (telephonenumber . 50)
+ (telexnumber . 52)
+ (telexterminalidentifier . 51)
+ (facsimiletelephonenumber . 22)
+ (x121address . 36)
+ (internationalisdnnumber . 36)
+ (registeredaddress . 41)
+ (destinationindicator . 44)
+ (preferreddeliverymethod . 14)
+ (presentationaddress . 43)
+ (supportedapplicationcontext . 38)
+ (member . 12)
+ (owner . 12)
+ (roleoccupant . 12)
+ (seealso . 12)
+ (userpassword . 40)
+ (usercertificate . 8)
+ (cacertificate . 8)
+ (authorityrevocationlist . 9)
+ (certificaterevocationlist . 9)
+ (crosscertificatepair . 10)
+ (name . 15)
+ (givenname . 15)
+ (initials . 15)
+ (generationqualifier . 15)
+ (x500uniqueidentifier . 6)
+ (dnqualifier . 44)
+ (enhancedsearchguide . 21)
+ (protocolinformation . 42)
+ (distinguishedname . 12)
+ (uniquemember . 34)
+ (houseidentifier . 15)
+ (supportedalgorithms . 49)
+ (deltarevocationlist . 9)
+ (dmdname . 15))
+ "A map of LDAP attribute names to their type object id minor number.
+This table is built from RFC2252 Section 5 and RFC2256 Section 5")
+
+
+;; Coding/decoding functions
+
+(defun ldap-encode-boolean (bool)
+ (if bool
+ "TRUE"
+ "FALSE"))
+
+(defun ldap-decode-boolean (str)
+ (cond
+ ((string-equal str "TRUE")
+ t)
+ ((string-equal str "FALSE")
+ nil)
+ (t
+ (error "Wrong LDAP boolean string: %s" str))))
+
+(defun ldap-encode-country-string (str)
+ ;; We should do something useful here...
+ (if (not (= 2 (length str)))
+ (error "Invalid country string: %s" str)))
+
+(defun ldap-decode-string (str)
+ (decode-coding-string str ldap-coding-system))
+
+(defun ldap-encode-string (str)
+ (encode-coding-string str ldap-coding-system))
+
+(defun ldap-decode-address (str)
+ (mapconcat 'ldap-decode-string
+ (split-string str "\\$")
+ "\n"))
+
+(defun ldap-encode-address (str)
+ (mapconcat 'ldap-encode-string
+ (split-string str "\n")
+ "$"))
+
+
+;; LDAP protocol functions
+
(defun ldap-get-host-parameter (host parameter)
"Get the value of PARAMETER for HOST in `ldap-host-parameters-alist'."
(plist-get (cdr (assoc host ldap-host-parameters-alist))
parameter))
+(defun ldap-decode-attribute (attr)
+ "Decode the attribute/value pair ATTR according to LDAP rules.
+The attribute name is looked up in `ldap-attribute-syntaxes-alist'
+and the corresponding decoder is then retrieved from
+`ldap-attribute-syntax-decoders' and applied on the value(s)."
+ (let* ((name (car attr))
+ (values (cdr attr))
+ (syntax-id (cdr (assq (intern (downcase name))
+ ldap-attribute-syntaxes-alist)))
+ decoder)
+ (if syntax-id
+ (setq decoder (aref ldap-attribute-syntax-decoders
+ (1- syntax-id)))
+ (setq decoder ldap-default-attribute-decoder))
+ (if decoder
+ (cons name (mapcar decoder values))
+ attr)))
+
+
(defun ldap-search (filter &optional host attributes attrsonly withdn)
"Perform an LDAP search.
-FILTER is the search filter in RFC1558 syntax, i.e. something that
+FILTER is the search filter in RFC1558 syntax, i.e., something that
looks like \"(cn=John Smith)\".
HOST is the LDAP host on which to perform the search.
ATTRIBUTES is a list of attributes to retrieve; nil means retrieve all.
entry according to the value of WITHDN."
(interactive "sFilter:")
(or host
- (setq host ldap-default-host))
- (or host
+ (setq host ldap-default-host)
(error "No LDAP host specified"))
(let ((host-plist (cdr (assoc host ldap-host-parameters-alist)))
- ldap)
+ ldap
+ result)
(message "Opening LDAP connection to %s..." host)
(setq ldap (ldap-open host host-plist))
(message "Searching with LDAP on %s..." host)
- (prog1 (ldap-search-internal ldap filter
- (plist-get host-plist 'base)
- (plist-get host-plist 'scope)
- attributes attrsonly withdn)
- (ldap-close ldap))))
+ (setq result (ldap-search-internal ldap filter
+ (plist-get host-plist 'base)
+ (plist-get host-plist 'scope)
+ attributes attrsonly withdn))
+ (ldap-close ldap)
+ (if ldap-ignore-attribute-codings
+ result
+ (mapcar (function
+ (lambda (record)
+ (mapcar 'ldap-decode-attribute record)))
+ result))))
(provide 'ldap)
;; Last Modified By: Heiko M|nkel <muenkel@tnt.uni-hannover.de>
;; Additional XEmacs integration By: Chuck Thompson <cthomp@cs.uiuc.edu>
;; Last Modified On: Thu Jul 1 14:23:00 1994
-;; RCS Info : $Revision: 1.3.2.1 $ $Locker: $
+;; RCS Info : $Revision: 1.3.2.2 $ $Locker: $
;; ========================================================================
;; NOTE: XEmacs must be redumped if this file is changed.
;;
;;(print (format "guessed-roots: %S" (paths-find-emacs-roots invocation-directory invocation-name)))
nil)))
- (load (concat default-directory "../lisp/dumped-lisp.el"))
+ (load (expand-file-name "../lisp/dumped-lisp.el"))
(let ((files preloaded-file-list)
file)
(nconc load-path (split-path (getenv "EMACSBOOTSTRAPLOADPATH"))))
(let (preloaded-file-list)
- (load (concat default-directory "../lisp/dumped-lisp.el"))
+ (load (expand-file-name "../lisp/dumped-lisp.el"))
(let ((package-preloaded-file-list
(packages-collect-package-dumped-lisps late-package-load-path)))
"Function that is called upon by `mouse-yank' to actually insert text.")
(defun mouse-consolidated-yank ()
+ "Insert the current selection or, if there is none under X insert the X cutbuffer.
+A mark is pushed, so that the inserted text lies between point and mark."
(interactive)
- (case (device-type)
- (x (x-yank-function))
- (tty (yank))
- (otherwise (yank))))
+ (if (not (console-on-window-system-p))
+ (yank)
+ (push-mark)
+ (if (region-active-p)
+ (if (consp zmacs-region-extent)
+ ;; pirated code from insert-rectangle in rect.el
+ ;; perhaps that code should be modified to handle a list of extents
+ ;; as the rectangle to be inserted?
+ (let ((lines zmacs-region-extent)
+ (insertcolumn (current-column))
+ (first t))
+ (push-mark)
+ (while lines
+ (or first
+ (progn
+ (forward-line 1)
+ (or (bolp) (insert ?\n))
+ (move-to-column insertcolumn t)))
+ (setq first nil)
+ (insert (extent-string (car lines)))
+ (setq lines (cdr lines))))
+ (insert (extent-string zmacs-region-extent)))
+ (insert-selection t))))
+
+(defun insert-selection (&optional check-cutbuffer-p move-point-event)
+ "Insert the current selection into buffer at point."
+ (interactive "P")
+ (let ((text (if check-cutbuffer-p
+ (or (condition-case () (get-selection) (error ()))
+ (get-cutbuffer)
+ (error "No selection or cut buffer available"))
+ (get-selection))))
+ (cond (move-point-event
+ (mouse-set-point move-point-event)
+ (push-mark (point)))
+ ((interactive-p)
+ (push-mark (point))))
+ (insert text)
+ ))
\f
(defun mouse-select ()
(defun mswindows-init-frame-faces (frame)
)
+;; Other functions expect these regexps
+(defconst mswindows-font-regexp
+ (let
+ ((- ":")
+ (fontname "\\([a-zA-Z ]+\\)")
+ (weight "\\([a-zA-Z]*\\)?")
+ (style "\\( [a-zA-Z]*\\)?")
+ (pointsize "\\([0-9]+\\)?")
+ (effects "\\([a-zA-Z ]*\\)?")
+ (charset "\\([a-zA-Z 0-9]*\\)")
+ )
+ (concat "^"
+ fontname - weight style - pointsize - effects - charset "$")))
;;; Fill in missing parts of a font spec. This is primarily intended as a
;;; helper function for the functions below.
(insert-rectangle clip)
(insert clip))))
-(defun mswindows-own-clipboard (string)
- "Paste the given string to the mswindows clipboard."
- (mswindows-set-clipboard string))
-(defvar mswindows-selection-owned-p nil
- "Whether we have a selection or not.
-MS-Windows has no concept of ownership; don't use this.")
-(defun mswindows-own-selection (data &optional type)
- "Make an MS-Windows selection of type TYPE and value DATA.
-The argument TYPE is ignored, and DATA specifies the contents.
-DATA may be a string,
-a symbol, an integer (or a cons of two integers or list of two integers).
-
-The selection may also be a cons of two markers pointing to the same buffer,
-or an overlay. In these cases, the selection is considered to be the text
-between the markers *at whatever time the selection is examined*.
-Thus, editing done in the buffer after you specify the selection
-can alter the effective value of the selection.
-
-The data may also be a vector of valid non-vector selection values.
-
-Interactively, the text of the region is used as the selection value."
- (interactive (if (not current-prefix-arg)
- (list (read-string "Store text for pasting: "))
- (list (substring (region-beginning) (region-end)))))
- (or (valid-simple-selection-p data)
- (and (vectorp data)
- (let ((valid t)
- (i (1- (length data))))
- (while (>= i 0)
- (or (valid-simple-selection-p (aref data i))
- (setq valid nil))
- (setq i (1- i)))
- valid))
- (signal 'error (list "invalid selection" data)))
- (if data
- (progn
-; (mswindows-set-clipboard data)
- (setq mswindows-selection-owned-p data))
- (setq mswindows-selection-owned-p nil))
- (setq primary-selection-extent
- (select-make-extent-for-selection
- data primary-selection-extent))
- (setq zmacs-region-stays t)
- data)
-
-(defun mswindows-disown-selection (&optional secondary-p)
- "Assuming we own the selection, disown it. With an argument, discard the
-secondary selection instead of the primary selection."
- (setq mswindows-selection-owned-p nil)
- (mswindows-delete-selection))
-
-(defun mswindows-selection-owner-p (&optional selection)
- "Return t if current emacs process owns the given Selection.
-The arg is ignored."
- (not (eq mswindows-selection-owned-p nil)))
;;; Code:
+(defvar selected-text-type
+ (if (featurep 'mule) '(COMPOUND_TEXT STRING) 'STRING)
+ "The type atom used to obtain selections from the X server.
+Can be either a valid X selection data type, or a list of such types.
+COMPOUND_TEXT and STRING are the most commonly used data types.
+If a list is provided, the types are tried in sequence until
+there is a successful conversion.")
+
(defun copy-primary-selection ()
"Copy the selection to the Clipboard and the kill ring."
(interactive)
(and (console-on-window-system-p)
(cut-copy-clear-internal 'copy)))
-(define-obsolete-function-alias
- 'x-copy-primary-selection
- 'copy-primary-selection)
(defun kill-primary-selection ()
"Copy the selection to the Clipboard and the kill ring, then delete it."
(interactive "*")
(and (console-on-window-system-p)
(cut-copy-clear-internal 'cut)))
-(define-obsolete-function-alias
- 'x-kill-primary-selection
- 'kill-primary-selection)
(defun delete-primary-selection ()
"Delete the selection without copying it to the Clipboard or the kill ring."
(interactive "*")
(and (console-on-window-system-p)
(cut-copy-clear-internal 'clear)))
-(define-obsolete-function-alias
- 'x-delete-primary-selection
- 'delete-primary-selection)
(defun yank-clipboard-selection ()
"Insert the current Clipboard selection at point."
(mswindows (mswindows-paste-clipboard))
(otherwise nil)))
-(defun selection-owner-p (&optional selection)
- "Return t if current XEmacs process owns the given Selection.
-The arg should be the name of the selection in question, typically one
-of the symbols PRIMARY, SECONDARY, or CLIPBOARD. (For convenience,
-the symbol nil is the same as PRIMARY, and t is the same as
-SECONDARY.)"
- (interactive)
- (case (device-type (selected-device))
- (x (x-selection-owner-p selection))
- (mswindows (mswindows-selection-owner-p selection))
- (otherwise nil)))
-
-(defun selection-exists-p (&optional selection)
- "Whether there is an owner for the given Selection.
-The arg should be the name of the selection in question, typically one
-of the symbols PRIMARY, SECONDARY, or CLIPBOARD. (For convenience,
-the symbol nil is the same as PRIMARY, and t is the same as
-SECONDARY."
- (interactive)
- (case (device-type (selected-device))
- (x (x-selection-exists-p selection))
- (mswindows (mswindows-selection-exists-p))
- (otherwise nil)))
+(define-device-method get-cutbuffer
+ "Return the value of one of the cut buffers.
+This will do nothing under anything other than X.")
+(defun get-selection (&optional type data-type)
+ "Return the value of a Windows selection.
+The argument TYPE (default `PRIMARY') says which selection,
+and the argument DATA-TYPE (default `STRING', or `COMPOUND_TEXT' under Mule)
+says how to convert the data."
+ (or type (setq type 'PRIMARY))
+ (or data-type (setq data-type selected-text-type))
+ (let ((text
+ (if (consp data-type)
+ (condition-case err
+ (get-selection-internal type (car data-type))
+ (selection-conversion-error
+ (if (cdr data-type)
+ (get-selection type (cdr data-type))
+ (signal (car err) (cdr err)))))
+ (get-selection-internal type data-type))))
+ (when (and (consp text) (symbolp (car text)))
+ (setq text (cdr text)))
+ (when (not (stringp text))
+ (error "Selection is not a string: %S" text))
+ text))
+
+;; FSFmacs calls this `x-set-selection', and reverses the
+;; arguments (duh ...). This order is more logical.
(defun own-selection (data &optional type)
"Make an Windows selection of type TYPE and value DATA.
The argument TYPE (default `PRIMARY') says which selection,
(interactive (if (not current-prefix-arg)
(list (read-string "Store text for pasting: "))
(list (substring (region-beginning) (region-end)))))
- (case (device-type (selected-device))
- (x (x-own-selection data type))
- (mswindows (mswindows-own-selection data type))
- (otherwise nil)))
+ ;FSFmacs huh?? It says:
+ ;; "This is for temporary compatibility with pre-release Emacs 19."
+ ;(if (stringp type)
+ ; (setq type (intern type)))
+ (or (valid-simple-selection-p data)
+ (and (vectorp data)
+ (let ((valid t)
+ (i (1- (length data))))
+ (while (>= i 0)
+ (or (valid-simple-selection-p (aref data i))
+ (setq valid nil))
+ (setq i (1- i)))
+ valid))
+ (signal 'error (list "invalid selection" data)))
+ (or type (setq type 'PRIMARY))
+ (if data
+ (own-selection-internal type data)
+ (disown-selection-internal type))
+ (cond ((eq type 'PRIMARY)
+ (setq primary-selection-extent
+ (select-make-extent-for-selection
+ data primary-selection-extent)))
+ ((eq type 'SECONDARY)
+ (setq secondary-selection-extent
+ (select-make-extent-for-selection
+ data secondary-selection-extent))))
+ (setq zmacs-region-stays t)
+ data)
+
+(defun dehilight-selection (selection)
+ "for use as a value of `lost-selection-hooks'."
+ (cond ((eq selection 'PRIMARY)
+ (if primary-selection-extent
+ (let ((inhibit-quit t))
+ (if (consp primary-selection-extent)
+ (mapcar 'delete-extent primary-selection-extent)
+ (delete-extent primary-selection-extent))
+ (setq primary-selection-extent nil)))
+ (if zmacs-regions (zmacs-deactivate-region)))
+ ((eq selection 'SECONDARY)
+ (if secondary-selection-extent
+ (let ((inhibit-quit t))
+ (if (consp secondary-selection-extent)
+ (mapcar 'delete-extent secondary-selection-extent)
+ (delete-extent secondary-selection-extent))
+ (setq secondary-selection-extent nil)))))
+ nil)
+
+(setq lost-selection-hooks 'dehilight-selection)
(defun own-clipboard (string)
- "Paste the given string to the Clipboard."
- (case (device-type (selected-device))
- (x (x-own-clipboard string))
- (mswindows (mswindows-own-clipboard string))
- (otherwise nil)))
+ "Paste the given string to the X Clipboard."
+ (own-selection string 'CLIPBOARD))
(defun disown-selection (&optional secondary-p)
"Assuming we own the selection, disown it. With an argument, discard the
secondary selection instead of the primary selection."
- (case (device-type (selected-device))
- (x (x-disown-selection secondary-p))
- (mswindows (mswindows-disown-selection secondary-p))
- (otherwise nil)))
-
+ (disown-selection-internal (if secondary-p 'SECONDARY 'PRIMARY)))
;; from x-init.el
;; selections and active regions
(default-mouse-track-next-move-rect start end previous-extent)
))
previous-extent))))
-(define-obsolete-function-alias
- 'x-select-make-extent-for-selection
- 'select-make-extent-for-selection)
;; moved from x-select.el
(defun valid-simple-selection-p (data)
(marker-buffer (cdr data)))
(buffer-live-p (marker-buffer (car data)))
(buffer-live-p (marker-buffer (cdr data))))))
-(define-obsolete-function-alias
- 'x-valid-simple-selection-p
- 'valid-simple-selection-p)
(defun cut-copy-clear-internal (mode)
(or (memq mode '(cut copy clear)) (error "unkown mode %S" mode))
(delete-region s e))))
(disown-selection nil)
)))
-(define-obsolete-function-alias
- 'x-cut-copy-clear-internal
- 'cut-copy-clear-internal)
+
+;;; Functions to convert the selection into various other selection
+;;; types. Every selection type that emacs handles is implemented
+;;; this way, except for TIMESTAMP, which is a special case. These are
+;;; all moved from x-select.el
+
+(defun select-convert-to-text (selection type value)
+ (cond ((stringp value)
+ value)
+ ((extentp value)
+ (save-excursion
+ (set-buffer (extent-object value))
+ (save-restriction
+ (widen)
+ (buffer-substring (extent-start-position value)
+ (extent-end-position value)))))
+ ((and (consp value)
+ (markerp (car value))
+ (markerp (cdr value)))
+ (or (eq (marker-buffer (car value)) (marker-buffer (cdr value)))
+ (signal 'error
+ (list "markers must be in the same buffer"
+ (car value) (cdr value))))
+ (save-excursion
+ (set-buffer (or (marker-buffer (car value))
+ (error "selection is in a killed buffer")))
+ (save-restriction
+ (widen)
+ (buffer-substring (car value) (cdr value)))))
+ (t nil)))
+
+(defun select-convert-to-string (selection type value)
+ (let ((outval (select-convert-to-text selection type value)))
+ ;; force the string to be not in Compound Text format.
+ (if (stringp outval)
+ (cons 'STRING outval)
+ outval)))
+
+(defun select-convert-to-compound-text (selection type value)
+ ;; converts to compound text automatically
+ (select-convert-to-text selection type value))
+
+(defun select-convert-to-length (selection type value)
+ (let ((value
+ (cond ((stringp value)
+ (length value))
+ ((extentp value)
+ (extent-length value))
+ ((and (consp value)
+ (markerp (car value))
+ (markerp (cdr value)))
+ (or (eq (marker-buffer (car value))
+ (marker-buffer (cdr value)))
+ (signal 'error
+ (list "markers must be in the same buffer"
+ (car value) (cdr value))))
+ (abs (- (car value) (cdr value)))))))
+ (if value ; force it to be in 32-bit format.
+ (cons (ash value -16) (logand value 65535))
+ nil)))
+
+(defun select-convert-to-targets (selection type value)
+ ;; return a vector of atoms, but remove duplicates first.
+ (let* ((all (cons 'TIMESTAMP (mapcar 'car selection-converter-alist)))
+ (rest all))
+ (while rest
+ (cond ((memq (car rest) (cdr rest))
+ (setcdr rest (delq (car rest) (cdr rest))))
+ ((eq (car (cdr rest)) '_EMACS_INTERNAL) ; shh, it's a secret
+ (setcdr rest (cdr (cdr rest))))
+ (t
+ (setq rest (cdr rest)))))
+ (apply 'vector all)))
+
+(defun select-convert-to-delete (selection type value)
+ (disown-selection-internal selection)
+ ;; A return value of nil means that we do not know how to do this conversion,
+ ;; and replies with an "error". A return value of NULL means that we have
+ ;; done the conversion (and any side-effects) but have no value to return.
+ 'NULL)
+
+(defun select-convert-to-filename (selection type value)
+ (cond ((extentp value)
+ (buffer-file-name (or (extent-object value)
+ (error "selection is in a killed buffer"))))
+ ((and (consp value)
+ (markerp (car value))
+ (markerp (cdr value)))
+ (buffer-file-name (or (marker-buffer (car value))
+ (error "selection is in a killed buffer"))))
+ (t nil)))
+
+(defun select-convert-to-charpos (selection type value)
+ (let (a b tmp)
+ (cond ((cond ((extentp value)
+ (setq a (extent-start-position value)
+ b (extent-end-position value)))
+ ((and (consp value)
+ (markerp (car value))
+ (markerp (cdr value)))
+ (setq a (car value)
+ b (cdr value))))
+ (setq a (1- a) b (1- b)) ; zero-based
+ (if (< b a) (setq tmp a a b b tmp))
+ (cons 'SPAN
+ (vector (cons (ash a -16) (logand a 65535))
+ (cons (ash b -16) (logand b 65535))))))))
+
+(defun select-convert-to-lineno (selection type value)
+ (let (a b buf tmp)
+ (cond ((cond ((extentp value)
+ (setq buf (extent-object value)
+ a (extent-start-position value)
+ b (extent-end-position value)))
+ ((and (consp value)
+ (markerp (car value))
+ (markerp (cdr value)))
+ (setq a (marker-position (car value))
+ b (marker-position (cdr value))
+ buf (marker-buffer (car value)))))
+ (save-excursion
+ (set-buffer buf)
+ (save-restriction
+ (widen)
+ (goto-char a)
+ (beginning-of-line)
+ (setq a (1+ (count-lines 1 (point))))
+ (goto-char b)
+ (beginning-of-line)
+ (setq b (1+ (count-lines 1 (point))))))
+ (if (< b a) (setq tmp a a b b tmp))
+ (cons 'SPAN
+ (vector (cons (ash a -16) (logand a 65535))
+ (cons (ash b -16) (logand b 65535))))))))
+
+(defun select-convert-to-colno (selection type value)
+ (let (a b buf tmp)
+ (cond ((cond ((extentp value)
+ (setq buf (extent-object value)
+ a (extent-start-position value)
+ b (extent-end-position value)))
+ ((and (consp value)
+ (markerp (car value))
+ (markerp (cdr value)))
+ (setq a (car value)
+ b (cdr value)
+ buf (marker-buffer a))))
+ (save-excursion
+ (set-buffer buf)
+ (goto-char a)
+ (setq a (current-column))
+ (goto-char b)
+ (setq b (current-column)))
+ (if (< b a) (setq tmp a a b b tmp))
+ (cons 'SPAN
+ (vector (cons (ash a -16) (logand a 65535))
+ (cons (ash b -16) (logand b 65535))))))))
+
+(defun select-convert-to-sourceloc (selection type value)
+ (let (a b buf file-name tmp)
+ (cond ((cond ((extentp value)
+ (setq buf (or (extent-object value)
+ (error "selection is in a killed buffer"))
+ a (extent-start-position value)
+ b (extent-end-position value)
+ file-name (buffer-file-name buf)))
+ ((and (consp value)
+ (markerp (car value))
+ (markerp (cdr value)))
+ (setq a (marker-position (car value))
+ b (marker-position (cdr value))
+ buf (or (marker-buffer (car value))
+ (error "selection is in a killed buffer"))
+ file-name (buffer-file-name buf))))
+ (save-excursion
+ (set-buffer buf)
+ (save-restriction
+ (widen)
+ (goto-char a)
+ (beginning-of-line)
+ (setq a (1+ (count-lines 1 (point))))
+ (goto-char b)
+ (beginning-of-line)
+ (setq b (1+ (count-lines 1 (point))))))
+ (if (< b a) (setq tmp a a b b tmp))
+ (format "%s:%d" file-name a)))))
+
+(defun select-convert-to-os (selection type size)
+ (symbol-name system-type))
+
+(defun select-convert-to-host (selection type size)
+ (system-name))
+
+(defun select-convert-to-user (selection type size)
+ (user-full-name))
+
+(defun select-convert-to-class (selection type size)
+ x-emacs-application-class)
+
+;; We do not try to determine the name Emacs was invoked with,
+;; because it is not clean for a program's behavior to depend on that.
+(defun select-convert-to-name (selection type size)
+ ;invocation-name
+ "xemacs")
+
+(defun select-convert-to-integer (selection type value)
+ (and (integerp value)
+ (cons (ash value -16) (logand value 65535))))
+
+(defun select-convert-to-atom (selection type value)
+ (and (symbolp value) value))
+
+(defun select-convert-to-identity (selection type value) ; used internally
+ (vector value))
+
+(setq selection-converter-alist
+ '((TEXT . select-convert-to-text)
+ (STRING . select-convert-to-string)
+ (COMPOUND_TEXT . select-convert-to-compound-text)
+ (TARGETS . select-convert-to-targets)
+ (LENGTH . select-convert-to-length)
+ (DELETE . select-convert-to-delete)
+ (FILE_NAME . select-convert-to-filename)
+ (CHARACTER_POSITION . select-convert-to-charpos)
+ (SOURCE_LOC . select-convert-to-sourceloc)
+ (LINE_NUMBER . select-convert-to-lineno)
+ (COLUMN_NUMBER . select-convert-to-colno)
+ (OWNER_OS . select-convert-to-os)
+ (HOST_NAME . select-convert-to-host)
+ (USER . select-convert-to-user)
+ (CLASS . select-convert-to-class)
+ (NAME . select-convert-to-name)
+ (ATOM . select-convert-to-atom)
+ (INTEGER . select-convert-to-integer)
+ (_EMACS_INTERNAL . select-convert-to-identity)
+ ))
;;; select.el ends here
;; Author: Jamie Zawinski <jwz@netscape.com>
;; Restructured by: Jonathan Stigelman <Stig@hackvan.com>
;; Mule-ized by: Martin Buchholz
+;; More restructuring for MS-Windows by Andy Piper <andy@xemacs.org>
;; This file is part of XEmacs.
;; along with XEmacs; see the file COPYING. If not, write to the
;; Free Software Foundation, 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
-
-;;; Commentary:
-;;;
-;;; Creates three menus, "Font", "Size", and "Weight", and puts them on the
-;;; "Options" menu. The contents of these menus are the superset of those
-;;; properties available on any fonts, but only the intersection of the three
-;;; sets is selectable at one time.
-;;;
-;;; Known Problems:
-;;; ===============
-;;; Items on the Font menu are selectable if and only if that font exists in
-;;; the same size and weight as the current font. This means that some fonts
-;;; are simply not reachable from some other fonts - if only one font comes
-;;; in only one point size (like "Nil", which comes only in 2), you will never
-;;; be able to select it. It would be better if the items on the Fonts menu
-;;; were always selectable, and selecting them would set the size to be the
-;;; closest size to the current font's size.
-;;;
-;;; This attempts to change all other faces in an analagous way to the change
-;;; that was made to the default face; if it can't, it will skip over the face.
-;;; However, this could leave incongruous font sizes around, which may cause
-;;; some nonreversibility problems if further changes are made. Perhaps it
-;;; should remember the initial fonts of all faces, and derive all subsequent
-;;; fonts from that initial state.
-;;;
-;;; xfontsel(1) is a lot more flexible (but probably harder to understand).
-;;;
-;;; The code to construct menus from all of the x11 fonts available from the
-;;; server is autoloaded and executed the very first time that one of the Font
-;;; menus is selected on each device. That is, if XEmacs has frames on two
-;;; different devices, then separate font menu information will be maintained
-;;; for each X display. If the font path changes after emacs has already
-;;; asked the X server on a particular display for its list of fonts, this
-;;; won't notice. Also, the first time that a font menu is posted on each
-;;; display will entail a lengthy delay, but that's better than slowing down
-;;; XEmacs startup. At any time (i.e.: after a font-path change or
-;;; immediately after device creation), you can call
-;;; `reset-device-font-menus' to rebuild the menus from all currently
-;;; available fonts.
-;;;
-;;; There is knowledge here about the regexp match numbers in
-;;; `x-font-regexp' and `x-font-regexp-foundry-and-family' defined in
-;;; x-faces.el.
-;;;
-;;; There are at least three kinds of fonts under X11r5:
-;;;
-;;; - bitmap fonts, which can be assumed to look as good as possible;
-;;; - bitmap fonts which have been (or can be) automatically scaled to
-;;; a new size, and which almost always look awful;
-;;; - and true outline fonts, which should look ok at any size, but in
-;;; practice (on at least some systems) look awful at any size, and
-;;; even in theory are unlikely ever to look as good as non-scaled
-;;; bitmap fonts.
-;;;
-;;; It would be nice to get this code to look for non-scaled bitmap fonts
-;;; first, then outline fonts, then scaled bitmap fonts as a last resort.
-;;; But it's not clear to me how to tell them apart based on their truenames
-;;; and/or the result of XListFonts(). I welcome any and all explanations
-;;; of the subtleties involved...
-;;;
-;;;
-;;; If You Think You'Re Seeing A Bug:
-;;; =================================
-;;; When reporting problems, send the following information:
-;;;
-;;; - Exactly what behavior you're seeing;
-;;; - The output of the `xlsfonts' program;
-;;; - The value of the variable `device-fonts-cache';
-;;; - The values of the following expressions, both before and after
-;;; making a selection from any of the fonts-related menus:
-;;; (face-font 'default)
-;;; (font-truename (face-font 'default))
-;;; (font-properties (face-font 'default))
-;;; - The values of the following variables after making a selection:
-;;; font-menu-preferred-resolution
-;;; font-menu-registry-encoding
-;;;
-;;; There is a common misconception that "*-courier-medium-r-*-11-*", also
-;;; known as "-adobe-courier-medium-r-normal--11-80-100-100-m-60-iso8859-1",
-;;; is an 11-point font. It is not -- it is an 11-pixel font at 100dpi,
-;;; which is an 8-point font (the number after -11- is the size in tenths
-;;; of points). So if you expect to be seeing an "11" entry in the "Size"
-;;; menu and are not, this may be why.
-;;;
-;;; In the real world (aka Solaris), one has to deal with fonts that
-;;; appear to be medium-i but are really light-r, and fonts that
-;;; resolve to different resolutions depending on the charset:
-;;;
-;;; (font-instance-truename
-;;; (make-font-instance "-*-mincho-medium-i-normal-*-*-*-*-*-*-*-jisx0201*-*"))
-;;; ==>
-;;; "-morisawa-ryumin light kl-light-r-normal--10-100-72-72-m-50-jisx0201.1976-0"
-;;;
-;;; (list-fonts "-dt-interface user-medium-r-normal-s*-*-*-*-*-*-*-*-*")
-;;; ==>
-;;; ("-dt-interface user-medium-r-normal-s sans-12-120-72-72-m-70-iso8859-1"
-;;; "-dt-interface user-medium-r-normal-s-14-120-75-75-m-120-jisx0208.1983-0"
-;;; "-dt-interface user-medium-r-normal-s-14-120-75-75-m-60-jisx0201.1976-0")
-
;;; Code:
;; #### - implement these...
;;; (defvar font-menu-ignore-proportional-fonts nil
;;; "*If non-nil, then the font menu will only show fixed-width fonts.")
-(defgroup font-menu ()
- "Settings for the font menu"
- :group 'x)
-
-;;;###autoload
-(defcustom font-menu-ignore-scaled-fonts t
- "*If non-nil, then the font menu will try to show only bitmap fonts."
- :type 'boolean
- :group 'font-menu)
-
-;;;###autoload
-(defcustom font-menu-this-frame-only-p nil
- "*If non-nil, then changing the default font from the font menu will only
-affect one frame instead of all frames."
- :type 'boolean
- :group 'font-menu)
-
-(defcustom font-menu-max-items 25
- "*Maximum number of items in the font menu
-If number of entries in a menu is larger than this value, split menu
-into submenus of nearly equal length. If nil, never split menu into
-submenus."
- :group 'font-menu
- :type '(choice (const :tag "no submenus" nil)
- (integer)))
-
-(defcustom font-menu-submenu-name-format "%-12.12s ... %.12s"
- "*Format specification of the submenu name.
-Used by `font-menu-split-long-menu' if the number of entries in a menu is
-larger than `font-menu-menu-max-items'.
-This string should contain one %s for the name of the first entry and
-one %s for the name of the last entry in the submenu.
-If the value is a function, it should return the submenu name. The
-function is be called with two arguments, the names of the first and
-the last entry in the menu."
- :group 'font-menu
- :type '(choice (string :tag "Format string")
- (function)))
-
-
-;; only call XListFonts (and parse) once per device.
-;; ( (device . [parsed-list-fonts family-menu size-menu weight-menu]) ...)
-(defvar device-fonts-cache nil)
+(require 'font-menu)
-(defvar font-menu-registry-encoding nil
+(defvar x-font-menu-registry-encoding nil
"Registry and encoding to use with font menu fonts.")
-(defvar font-menu-preferred-resolution "*-*"
- "Preferred horizontal and vertical font menu resolution (e.g. \"75-75\").")
-
-(defvar fonts-menu-junk-families
+(defvar x-fonts-menu-junk-families
(purecopy
(mapconcat
#'identity
"\\|"))
"A regexp matching font families which are uninteresting (e.g. cursor fonts).")
-(eval-when-compile
- (defsubst device-fonts-cache ()
- (or (cdr (assq (selected-device) device-fonts-cache))
- (reset-device-font-menus (selected-device)))))
-
(defun hack-font-truename (fn)
"Filter the output of `font-instance-truename' to deal with Japanese fontsets."
(if (string-match "," (font-instance-truename fn))
ret)
(font-instance-truename fn)))
-;;;###autoload
-(fset 'install-font-menus 'reset-device-font-menus)
-(make-obsolete 'install-font-menus 'reset-device-font-menus)
-
(defvar x-font-regexp-ascii nil
"This is used to filter out font families that can't display ASCII text.
It must be set at run-time.")
-(defun vassoc (key valist)
- "Search VALIST for a vector whose first element is equal to KEY.
-See also `assoc'."
- ;; by Stig@hackvan.com
- (let (el)
- (catch 'done
- (while (setq el (pop valist))
- (and (equal key (aref el 0))
- (throw 'done el))))))
-
;;;###autoload
-(defun reset-device-font-menus (&optional device debug)
+(defun x-reset-device-font-menus (device &optional debug)
"Generates the `Font', `Size', and `Weight' submenus for the Options menu.
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
;; by Stig@hackvan.com
;; #### - this should implement a `menus-only' option, which would
;; recalculate the menus from the cache w/o having to do list-fonts again.
- (message "Getting list of fonts from server... ")
- (if (or noninteractive
- (not (or device (setq device (selected-device))))
- (not (eq (device-type device) 'x)))
- nil
- (unless x-font-regexp-ascii
- (setq x-font-regexp-ascii (if (featurep 'mule)
- (charset-registry 'ascii)
- "iso8859-1")))
- (setq font-menu-registry-encoding
- (if (featurep 'mule) "*-*" "iso8859-1"))
- (let ((case-fold-search t)
- family size weight entry monospaced-p
- dev-cache cache families sizes weights)
- (dolist (name (cond ((null debug) ; debugging kludge
- (list-fonts "*-*-*-*-*-*-*-*-*-*-*-*-*-*" device))
- ((stringp debug) (split-string debug "\n"))
- (t debug)))
- (when (and (string-match x-font-regexp-ascii name)
- (string-match x-font-regexp name))
- (setq weight (capitalize (match-string 1 name))
- size (string-to-int (match-string 6 name)))
- (or (string-match x-font-regexp-foundry-and-family name)
- (error "internal error"))
- (setq family (capitalize (match-string 1 name)))
- (or (string-match x-font-regexp-spacing name)
- (error "internal error"))
- (setq monospaced-p (string= "m" (match-string 1 name)))
- (unless (string-match fonts-menu-junk-families family)
- (setq entry (or (vassoc family cache)
- (car (setq cache
- (cons (vector family nil nil t)
- cache)))))
- (or (member family families) (push family families))
- (or (member weight weights) (push weight weights))
- (or (member size sizes) (push size sizes))
- (or (member weight (aref entry 1)) (push weight (aref entry 1)))
- (or (member size (aref entry 2)) (push size (aref entry 2)))
- (aset entry 3 (and (aref entry 3) monospaced-p)))))
- ;;
- ;; Hack scalable fonts.
- ;; Some fonts come only in scalable versions (the only size is 0)
- ;; and some fonts come in both scalable and non-scalable versions
- ;; (one size is 0). If there are any scalable fonts at all, make
- ;; sure that the union of all point sizes contains at least some
- ;; common sizes - it's possible that some sensible sizes might end
- ;; up not getting mentioned explicitly.
- ;;
- (if (member 0 sizes)
- (let ((common '(60 80 100 120 140 160 180 240)))
- (while common
- (or;;(member (car common) sizes) ; not enough slack
- (let ((rest sizes)
- (done nil))
- (while (and (not done) rest)
- (if (and (> (car common) (- (car rest) 5))
- (< (car common) (+ (car rest) 5)))
- (setq done t))
- (setq rest (cdr rest)))
- done)
- (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) '<)))
-
- (message "Getting list of fonts from server... done.")
-
- (setq dev-cache (assq device device-fonts-cache))
- (or dev-cache
- (setq dev-cache (car (push (list device) device-fonts-cache))))
- (setcdr
- dev-cache
- (vector
- cache
- (mapcar (lambda (x)
- (vector x
- (list 'font-menu-set-font x nil nil)
- ':style 'radio ':active nil ':selected nil))
- families)
- (mapcar (lambda (x)
- (vector (if (/= 0 (% x 10))
- ;; works with no LISP_FLOAT_TYPE
- (concat (int-to-string (/ x 10)) "."
- (int-to-string (% x 10)))
- (int-to-string (/ x 10)))
- (list 'font-menu-set-font nil nil x)
- ':style 'radio ':active nil ':selected nil))
- sizes)
- (mapcar (lambda (x)
- (vector x
- (list 'font-menu-set-font nil x nil)
- ':style 'radio ':active nil ':selected nil))
- weights)))
- (cdr dev-cache))))
+ (unless x-font-regexp-ascii
+ (setq x-font-regexp-ascii (if (featurep 'mule)
+ (charset-registry 'ascii)
+ "iso8859-1")))
+ (setq x-font-menu-registry-encoding
+ (if (featurep 'mule) "*-*" "iso8859-1"))
+ (let ((case-fold-search t)
+ family size weight entry monospaced-p
+ dev-cache cache families sizes weights)
+ (dolist (name (cond ((null debug) ; debugging kludge
+ (list-fonts "*-*-*-*-*-*-*-*-*-*-*-*-*-*" device))
+ ((stringp debug) (split-string debug "\n"))
+ (t debug)))
+ (when (and (string-match x-font-regexp-ascii name)
+ (string-match x-font-regexp name))
+ (setq weight (capitalize (match-string 1 name))
+ size (string-to-int (match-string 6 name)))
+ (or (string-match x-font-regexp-foundry-and-family name)
+ (error "internal error"))
+ (setq family (capitalize (match-string 1 name)))
+ (or (string-match x-font-regexp-spacing name)
+ (error "internal error"))
+ (setq monospaced-p (string= "m" (match-string 1 name)))
+ (unless (string-match x-fonts-menu-junk-families family)
+ (setq entry (or (vassoc family cache)
+ (car (setq cache
+ (cons (vector family nil nil t)
+ cache)))))
+ (or (member family families) (push family families))
+ (or (member weight weights) (push weight weights))
+ (or (member size sizes) (push size sizes))
+ (or (member weight (aref entry 1)) (push weight (aref entry 1)))
+ (or (member size (aref entry 2)) (push size (aref entry 2)))
+ (aset entry 3 (and (aref entry 3) monospaced-p)))))
+ ;;
+ ;; Hack scalable fonts.
+ ;; Some fonts come only in scalable versions (the only size is 0)
+ ;; and some fonts come in both scalable and non-scalable versions
+ ;; (one size is 0). If there are any scalable fonts at all, make
+ ;; sure that the union of all point sizes contains at least some
+ ;; common sizes - it's possible that some sensible sizes might end
+ ;; up not getting mentioned explicitly.
+ ;;
+ (if (member 0 sizes)
+ (let ((common '(60 80 100 120 140 160 180 240)))
+ (while common
+ (or;;(member (car common) sizes) ; not enough slack
+ (let ((rest sizes)
+ (done nil))
+ (while (and (not done) rest)
+ (if (and (> (car common) (- (car rest) 5))
+ (< (car common) (+ (car rest) 5)))
+ (setq done t))
+ (setq rest (cdr rest)))
+ done)
+ (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 dev-cache (assq device device-fonts-cache))
+ (or dev-cache
+ (setq dev-cache (car (push (list device) device-fonts-cache))))
+ (setcdr
+ dev-cache
+ (vector
+ cache
+ (mapcar (lambda (x)
+ (vector x
+ (list 'font-menu-set-font x nil nil)
+ ':style 'radio ':active nil ':selected nil))
+ families)
+ (mapcar (lambda (x)
+ (vector (if (/= 0 (% x 10))
+ ;; works with no LISP_FLOAT_TYPE
+ (concat (int-to-string (/ x 10)) "."
+ (int-to-string (% x 10)))
+ (int-to-string (/ x 10)))
+ (list 'font-menu-set-font nil nil x)
+ ':style 'radio ':active nil ':selected nil))
+ sizes)
+ (mapcar (lambda (x)
+ (vector x
+ (list 'font-menu-set-font nil x nil)
+ ':style 'radio ':active nil ':selected nil))
+ weights)))
+ (cdr dev-cache)))
;; Extract font information from a face. We examine both the
;; user-specified font name and the canonical (`true') font name.
;; We use the user-specified one if possible, else use the truename.
;; If the user didn't specify one (with "-dt-*-*", for example)
;; get the truename and use the possibly suboptimal data from that.
-(defun* font-menu-font-data (face dcache)
+;;;###autoload
+(defun* x-font-menu-font-data (face dcache)
(let* ((case-fold-search t)
(domain (if font-menu-this-frame-only-p
(selected-frame)
(setq family (capitalize (match-string 1 truename)))
(setq entry (vassoc family (aref dcache 0))))
(when (null entry)
- (return-from font-menu-font-data (make-vector 5 nil)))
+ (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)))
(vector entry family size weight slant)))
-(defun font-menu-split-long-menu (menu)
- "Split MENU according to `font-menu-max-items'."
- (let ((len (length menu)))
- (if (or (null font-menu-max-items)
- (null (featurep 'lisp-float-type))
- (<= len font-menu-max-items))
- menu
- ;; Submenu is max 2 entries longer than menu, never shorter, number of
- ;; entries in submenus differ by at most one (with longer submenus first)
- (let* ((outer (floor (sqrt len)))
- (inner (/ len outer))
- (rest (% len outer))
- (result nil))
- (setq menu (reverse menu))
- (while menu
- (let ((in inner)
- (sub nil)
- (to (car menu)))
- (while (> in 0)
- (setq in (1- in)
- sub (cons (car menu) sub)
- menu (cdr menu)))
- (setq result
- (cons (cons (if (stringp font-menu-submenu-name-format)
- (format font-menu-submenu-name-format
- (aref (car sub) 0) (aref to 0))
- (funcall font-menu-submenu-name-format
- (aref (car sub) 0) (aref to 0)))
- sub)
- result)
- rest (1+ rest))
- (if (= rest outer) (setq inner (1+ inner)))))
- result))))
-
-;;;###autoload
-(defun font-menu-family-constructor (ignored)
- (catch 'menu
- (unless (eq 'x (device-type (selected-device)))
- (throw 'menu '(["Cannot parse current font" ding nil])))
- (let* ((dcache (device-fonts-cache))
- (font-data (font-menu-font-data 'default dcache))
- (entry (aref font-data 0))
- (family (aref font-data 1))
- (size (aref font-data 2))
- (weight (aref font-data 3))
- f)
- (unless family
- (throw 'menu '(["Cannot parse current font" ding nil])))
- ;; Items on the Font menu are enabled iff that font exists in
- ;; the same size and weight as the current font (scalable fonts
- ;; exist in every size). Only the current font is marked as
- ;; selected.
- (font-menu-split-long-menu
- (mapcar
- (lambda (item)
- (setq f (aref item 0)
- entry (vassoc f (aref dcache 0)))
- ;; The user can no longer easily control the weight using the menu
- ;; Note it is silly anyway as it could very well be that the font
- ;; has no common size+weight combinations with the default font.
-;; (if (and (member weight (aref entry 1))
-;; (or (member size (aref entry 2))
-;; (and (not font-menu-ignore-scaled-fonts)
-;; (member 0 (aref entry 2)))))
-;; (enable-menu-item item)
-;; (disable-menu-item item))
- (if (and font-menu-ignore-scaled-fonts (member 0 (aref entry 2)))
- (disable-menu-item item)
- (enable-menu-item item))
- (if (string-equal family f)
- (select-toggle-menu-item item)
- (deselect-toggle-menu-item item))
- item)
- (aref dcache 1))))))
-
-;;;###autoload
-(defun font-menu-size-constructor (ignored)
- (catch 'menu
- (unless (eq 'x (device-type (selected-device)))
- (throw 'menu '(["Cannot parse current font" ding nil])))
- (let* ((dcache (device-fonts-cache))
- (font-data (font-menu-font-data 'default dcache))
- (entry (aref font-data 0))
- (family (aref font-data 1))
- (size (aref font-data 2))
- ;;(weight (aref font-data 3))
- s)
- (unless family
- (throw 'menu '(["Cannot parse current font" ding nil])))
- ;; Items on the Size menu are enabled iff current font has
- ;; that size. Only the size of the current font is selected.
- ;; (If the current font comes in size 0, it is scalable, and
- ;; thus has every size.)
- (mapcar
- (lambda (item)
- (setq s (nth 3 (aref item 1)))
- (if (or (member s (aref entry 2))
- (and (not font-menu-ignore-scaled-fonts)
- (member 0 (aref entry 2))))
- (enable-menu-item item)
- (disable-menu-item item))
- (if (eq size s)
- (select-toggle-menu-item item)
- (deselect-toggle-menu-item item))
- item)
- (aref dcache 2)))))
-
-;;;###autoload
-(defun font-menu-weight-constructor (ignored)
- (catch 'menu
- (unless (eq 'x (device-type (selected-device)))
- (throw 'menu '(["Cannot parse current font" ding nil])))
- (let* ((dcache (device-fonts-cache))
- (font-data (font-menu-font-data 'default dcache))
- (entry (aref font-data 0))
- (family (aref font-data 1))
- ;;(size (aref font-data 2))
- (weight (aref font-data 3))
- w)
- (unless family
- (throw 'menu '(["Cannot parse current font" ding nil])))
- ;; Items on the Weight menu are enabled iff current font
- ;; has that weight. Only the weight of the current font
- ;; is selected.
- (mapcar
- (lambda (item)
- (setq w (aref item 0))
- (if (member w (aref entry 1))
- (enable-menu-item item)
- (disable-menu-item item))
- (if (string-equal weight w)
- (select-toggle-menu-item item)
- (deselect-toggle-menu-item item))
- item)
- (aref dcache 3)))))
-
-\f
-;;; Changing font sizes
-
-(defun font-menu-set-font (family weight size)
- ;; This is what gets run when an item is selected from any of the three
- ;; fonts menus. It needs to be rather clever.
- ;; (size is measured in 10ths of points.)
- (let* ((dcache (device-fonts-cache))
- (font-data (font-menu-font-data 'default dcache))
- (from-family (aref font-data 1))
- (from-size (aref font-data 2))
- (from-weight (aref font-data 3))
- (from-slant (aref font-data 4))
- new-default-face-font
- new-props)
- (unless from-family
- (signal 'error '("couldn't parse font name for default face")))
- (when weight
- (signal 'error '("Setting weight currently not supported")))
- (setq new-default-face-font
- (font-menu-load-font (or family from-family)
- (or weight from-weight)
- (or size from-size)
- from-slant
- font-menu-preferred-resolution))
- (dolist (face (delq 'default (face-list)))
- (when (face-font-instance face)
- (message "Changing font of `%s'..." face)
- (condition-case c
- (font-menu-change-face face
- from-family from-weight from-size
- family weight size)
- (error
- (display-error c nil)
- (sit-for 1)))))
- ;; Set the default face's font after hacking the other faces, so that
- ;; the frame size doesn't change until we are all done.
-
- ;; If we need to be frame local we do the changes ourselves.
- (if font-menu-this-frame-only-p
- ;;; WMP - we need to honor font-menu-this-frame-only-p here!
- (set-face-font 'default new-default-face-font
- (and font-menu-this-frame-only-p (selected-frame)))
- ;; OK Let Customize do it.
- (when (and family (not (equal family from-family)))
- (setq new-props (append (list :family family) new-props)))
- (when (and size (not (equal size from-size)))
- (setq new-props (append
- (list :size (concat (int-to-string (/ size 10)) "pt")) new-props)))
- (custom-set-face-update-spec 'default '((type x)) new-props)
- (message "Font %s" (face-font-name 'default)))))
-
-
-(defun font-menu-change-face (face
- from-family from-weight from-size
- to-family to-weight to-size)
- (or (symbolp face) (signal 'wrong-type-argument (list 'symbolp face)))
- (let* ((dcache (device-fonts-cache))
- (font-data (font-menu-font-data face dcache))
- (face-family (aref font-data 1))
- (face-size (aref font-data 2))
- (face-weight (aref font-data 3))
- (face-slant (aref font-data 4)))
-
- (or face-family
- (signal 'error (list "couldn't parse font name for face" face)))
-
- ;; If this face matches the old default face in the attribute we
- ;; are changing, then change it to the new attribute along that
- ;; dimension. Also, the face must have its own global attribute.
- ;; If its value is inherited, we don't touch it. If any of this
- ;; is not true, we leave it alone.
- (when (and (face-font face 'global)
- (cond
- (to-family (string-equal face-family from-family))
- (to-weight (string-equal face-weight from-weight))
- (to-size (= face-size from-size))))
- (set-face-font face
- (font-menu-load-font (or to-family face-family)
- (or to-weight face-weight)
- (or to-size face-size)
- face-slant
- font-menu-preferred-resolution)
- (and font-menu-this-frame-only-p
- (selected-frame))))))
-
-(defun font-menu-load-font (family weight size slant resolution)
+(defun x-font-menu-load-font (family weight size slant resolution)
"Try to load a font with the requested properties.
The weight, slant and resolution are only hints."
(when (integerp size) (setq size (int-to-string size)))
(make-font-instance
(concat "-*-" family "-" weight "-" slant "-*-*-*-"
size "-" resolution "-*-*-"
- font-menu-registry-encoding)
+ x-font-menu-registry-encoding)
nil t))
(throw 'got-font font))))))))
-(defun flush-device-fonts-cache (device)
- ;; by Stig@hackvan.com
- (let ((elt (assq device device-fonts-cache)))
- (and elt
- (setq device-fonts-cache (delq elt device-fonts-cache)))))
-
-(add-hook 'delete-device-hook 'flush-device-fonts-cache)
-
(provide 'x-font-menu)
;;; x-font-menu.el ends here
;;(define-key global-map '(shift button2) 'x-mouse-kill)
(define-key global-map '(control button2) 'x-set-point-and-move-selection)
+(define-obsolete-function-alias 'x-insert-selection 'insert-selection)
+
(defun x-mouse-kill (event)
"Kill the text between the point and mouse and copy it to the clipboard and
to the cut buffer"
(let ((old-point (point)))
(mouse-set-point event)
(let ((s (buffer-substring old-point (point))))
- (x-own-clipboard s)
+ (own-clipboard s)
(x-store-cutbuffer s))
(kill-region old-point (point))))
-(defun x-yank-function ()
- "Insert the current X selection or, if there is none, insert the X cutbuffer.
-A mark is pushed, so that the inserted text lies between point and mark."
- (push-mark)
- (if (region-active-p)
- (if (consp zmacs-region-extent)
- ;; pirated code from insert-rectangle in rect.el
- ;; perhaps that code should be modified to handle a list of extents
- ;; as the rectangle to be inserted?
- (let ((lines zmacs-region-extent)
- (insertcolumn (current-column))
- (first t))
- (push-mark)
- (while lines
- (or first
- (progn
- (forward-line 1)
- (or (bolp) (insert ?\n))
- (move-to-column insertcolumn t)))
- (setq first nil)
- (insert (extent-string (car lines)))
- (setq lines (cdr lines))))
- (insert (extent-string zmacs-region-extent)))
- (x-insert-selection t)))
-
-(defun x-insert-selection (&optional check-cutbuffer-p move-point-event)
- "Insert the current selection into buffer at point."
- (interactive "P")
- (let ((text (if check-cutbuffer-p
- (or (condition-case () (x-get-selection) (error ()))
- (x-get-cutbuffer)
- (error "No selection or cut buffer available"))
- (x-get-selection))))
- (cond (move-point-event
- (mouse-set-point move-point-event)
- (push-mark (point)))
- ((interactive-p)
- (push-mark (point))))
- (insert text)
- ))
-
(make-obsolete 'x-set-point-and-insert-selection 'mouse-yank)
(defun x-set-point-and-insert-selection (event)
"Set point where clicked and insert the primary selection or the cut buffer."
;; to fail; just let the appropriate error message get issued. (We need
;; to insert the selection and set point first, or the selection may
;; get inserted at the wrong place.)
- (and (x-selection-owner-p)
+ (and (selection-owner-p)
primary-selection-extent
- (x-insert-selection t event))
+ (insert-selection t event))
(kill-primary-selection))
(defun mouse-track-and-copy-to-cutbuffer (event)
;;; Code:
-(defvar x-selected-text-type
- (if (featurep 'mule) '(COMPOUND_TEXT STRING) 'STRING)
- "The type atom used to obtain selections from the X server.
-Can be either a valid X selection data type, or a list of such types.
-COMPOUND_TEXT and STRING are the most commonly used data types.
-If a list is provided, the types are tried in sequence until
-there is a successful conversion.")
-
-(defun x-get-selection (&optional type data-type)
- "Return the value of an X Windows selection.
-The argument TYPE (default `PRIMARY') says which selection,
-and the argument DATA-TYPE (default `STRING', or `COMPOUND_TEXT' under Mule)
-says how to convert the data."
- (or type (setq type 'PRIMARY))
- (or data-type (setq data-type x-selected-text-type))
- (let ((text
- (if (consp data-type)
- (condition-case err
- (x-get-selection-internal type (car data-type))
- (selection-conversion-error
- (if (cdr data-type)
- (x-get-selection type (cdr data-type))
- (signal (car err) (cdr err)))))
- (x-get-selection-internal type data-type))))
- (when (and (consp text) (symbolp (car text)))
- (setq text (cdr text)))
- (when (not (stringp text))
- (error "Selection is not a string: %S" text))
- text))
+(define-obsolete-function-alias 'x-selection-exists-p 'selection-exists-p)
+(define-obsolete-function-alias 'x-selection-owner-p 'selection-owner-p)
+(define-obsolete-variable-alias 'x-selection-converter-alist 'selection-converter-alist)
+(define-obsolete-variable-alias 'x-lost-selection-hooks 'lost-selection-hooks)
+(define-obsolete-variable-alias 'x-selected-text-type 'selected-text-type)
+(define-obsolete-function-alias 'x-valid-simple-selection-p 'valid-simple-selection-p)
+(define-obsolete-function-alias 'x-own-selection 'own-selection)
+(define-obsolete-function-alias 'x-disown-selection 'disown-selection)
+(define-obsolete-function-alias 'x-delete-primary-selection 'delete-primary-selection)
+(define-obsolete-function-alias 'x-copy-primary-selection 'copy-primary-selection)
+(define-obsolete-function-alias 'x-kill-primary-selection 'kill-primary-selection)
+(define-obsolete-function-alias 'x-select-make-extent-for-selection
+ 'select-make-extent-for-selection)
+(define-obsolete-function-alias 'x-cut-copy-clear-internal 'cut-copy-clear-internal)
+(define-obsolete-function-alias 'x-get-selection 'get-selection)
(defun x-get-secondary-selection ()
"Return text selected from some X window."
- (x-get-selection 'SECONDARY))
+ (get-selection 'SECONDARY))
(defun x-get-clipboard ()
"Return text pasted to the clipboard."
- (x-get-selection 'CLIPBOARD))
-
-;; FSFmacs calls this `x-set-selection', and reverses the
-;; arguments (duh ...). This order is more logical.
-(defun x-own-selection (data &optional type)
- "Make an X Windows selection of type TYPE and value DATA.
-The argument TYPE (default `PRIMARY') says which selection,
-and DATA specifies the contents. DATA may be a string,
-a symbol, an integer (or a cons of two integers or list of two integers).
-
-The selection may also be a cons of two markers pointing to the same buffer,
-or an overlay. In these cases, the selection is considered to be the text
-between the markers *at whatever time the selection is examined*.
-Thus, editing done in the buffer after you specify the selection
-can alter the effective value of the selection.
-
-The data may also be a vector of valid non-vector selection values.
-
-Interactively, the text of the region is used as the selection value."
- (interactive (if (not current-prefix-arg)
- (list (read-string "Store text for pasting: "))
- (list (substring (region-beginning) (region-end)))))
- ;FSFmacs huh?? It says:
- ;; "This is for temporary compatibility with pre-release Emacs 19."
- ;(if (stringp type)
- ; (setq type (intern type)))
- (or (x-valid-simple-selection-p data)
- (and (vectorp data)
- (let ((valid t)
- (i (1- (length data))))
- (while (>= i 0)
- (or (x-valid-simple-selection-p (aref data i))
- (setq valid nil))
- (setq i (1- i)))
- valid))
- (signal 'error (list "invalid selection" data)))
- (or type (setq type 'PRIMARY))
- (if data
- (x-own-selection-internal type data)
- (x-disown-selection-internal type))
- (cond ((eq type 'PRIMARY)
- (setq primary-selection-extent
- (select-make-extent-for-selection
- data primary-selection-extent)))
- ((eq type 'SECONDARY)
- (setq secondary-selection-extent
- (select-make-extent-for-selection
- data secondary-selection-extent))))
- (setq zmacs-region-stays t)
- data)
-
-(defun x-valid-simple-selection-p (data)
- (valid-simple-selection-p data))
+ (get-selection 'CLIPBOARD))
(defun x-own-secondary-selection (selection &optional type)
"Make a secondary X Selection of the given argument. The argument may be a
(copy-marker (mark-marker))))))
(x-own-selection selection 'SECONDARY))
-
-(defun x-own-clipboard (string)
- "Paste the given string to the X Clipboard."
- (x-own-selection string 'CLIPBOARD))
-
-
-(defun x-disown-selection (&optional secondary-p)
- "Assuming we own the selection, disown it. With an argument, discard the
-secondary selection instead of the primary selection."
- (x-disown-selection-internal (if secondary-p 'SECONDARY 'PRIMARY)))
-
-(defun x-dehilight-selection (selection)
- "for use as a value of `x-lost-selection-hooks'."
- (cond ((eq selection 'PRIMARY)
- (if primary-selection-extent
- (let ((inhibit-quit t))
- (if (consp primary-selection-extent)
- (mapcar 'delete-extent primary-selection-extent)
- (delete-extent primary-selection-extent))
- (setq primary-selection-extent nil)))
- (if zmacs-regions (zmacs-deactivate-region)))
- ((eq selection 'SECONDARY)
- (if secondary-selection-extent
- (let ((inhibit-quit t))
- (if (consp secondary-selection-extent)
- (mapcar 'delete-extent secondary-selection-extent)
- (delete-extent secondary-selection-extent))
- (setq secondary-selection-extent nil)))))
- nil)
-
-(setq x-lost-selection-hooks 'x-dehilight-selection)
-
(defun x-notice-selection-requests (selection type successful)
"for possible use as the value of x-sent-selection-hooks."
(if (not successful)
(defun xselect-kill-buffer-hook-1 (selection)
(let (value)
(if (and (x-selection-owner-p selection)
- (setq value (x-get-selection-internal selection '_EMACS_INTERNAL))
+ (setq value (get-selection-internal selection '_EMACS_INTERNAL))
;; The _EMACS_INTERNAL selection type has a converter registered
;; for it that does no translation. This only works if emacs is
;; requesting the selection from itself. We could have done this
(push-mark)
(insert clip)))
\f
-;;; Functions to convert the selection into various other selection types.
-;;; Every selection type that emacs handles is implemented this way, except
-;;; for TIMESTAMP, which is a special case.
-
-(defun xselect-convert-to-text (selection type value)
- (cond ((stringp value)
- value)
- ((extentp value)
- (save-excursion
- (set-buffer (extent-object value))
- (save-restriction
- (widen)
- (buffer-substring (extent-start-position value)
- (extent-end-position value)))))
- ((and (consp value)
- (markerp (car value))
- (markerp (cdr value)))
- (or (eq (marker-buffer (car value)) (marker-buffer (cdr value)))
- (signal 'error
- (list "markers must be in the same buffer"
- (car value) (cdr value))))
- (save-excursion
- (set-buffer (or (marker-buffer (car value))
- (error "selection is in a killed buffer")))
- (save-restriction
- (widen)
- (buffer-substring (car value) (cdr value)))))
- (t nil)))
-
-(defun xselect-convert-to-string (selection type value)
- (let ((outval (xselect-convert-to-text selection type value)))
- ;; force the string to be not in Compound Text format.
- (if (stringp outval)
- (cons 'STRING outval)
- outval)))
-
-(defun xselect-convert-to-compound-text (selection type value)
- ;; converts to compound text automatically
- (xselect-convert-to-text selection type value))
-
-(defun xselect-convert-to-length (selection type value)
- (let ((value
- (cond ((stringp value)
- (length value))
- ((extentp value)
- (extent-length value))
- ((and (consp value)
- (markerp (car value))
- (markerp (cdr value)))
- (or (eq (marker-buffer (car value))
- (marker-buffer (cdr value)))
- (signal 'error
- (list "markers must be in the same buffer"
- (car value) (cdr value))))
- (abs (- (car value) (cdr value)))))))
- (if value ; force it to be in 32-bit format.
- (cons (ash value -16) (logand value 65535))
- nil)))
-
-(defun xselect-convert-to-targets (selection type value)
- ;; return a vector of atoms, but remove duplicates first.
- (let* ((all (cons 'TIMESTAMP (mapcar 'car selection-converter-alist)))
- (rest all))
- (while rest
- (cond ((memq (car rest) (cdr rest))
- (setcdr rest (delq (car rest) (cdr rest))))
- ((eq (car (cdr rest)) '_EMACS_INTERNAL) ; shh, it's a secret
- (setcdr rest (cdr (cdr rest))))
- (t
- (setq rest (cdr rest)))))
- (apply 'vector all)))
-
-(defun xselect-convert-to-delete (selection type value)
- (x-disown-selection-internal selection)
- ;; A return value of nil means that we do not know how to do this conversion,
- ;; and replies with an "error". A return value of NULL means that we have
- ;; done the conversion (and any side-effects) but have no value to return.
- 'NULL)
-
-(defun xselect-convert-to-filename (selection type value)
- (cond ((extentp value)
- (buffer-file-name (or (extent-object value)
- (error "selection is in a killed buffer"))))
- ((and (consp value)
- (markerp (car value))
- (markerp (cdr value)))
- (buffer-file-name (or (marker-buffer (car value))
- (error "selection is in a killed buffer"))))
- (t nil)))
-
-(defun xselect-convert-to-charpos (selection type value)
- (let (a b tmp)
- (cond ((cond ((extentp value)
- (setq a (extent-start-position value)
- b (extent-end-position value)))
- ((and (consp value)
- (markerp (car value))
- (markerp (cdr value)))
- (setq a (car value)
- b (cdr value))))
- (setq a (1- a) b (1- b)) ; zero-based
- (if (< b a) (setq tmp a a b b tmp))
- (cons 'SPAN
- (vector (cons (ash a -16) (logand a 65535))
- (cons (ash b -16) (logand b 65535))))))))
-
-(defun xselect-convert-to-lineno (selection type value)
- (let (a b buf tmp)
- (cond ((cond ((extentp value)
- (setq buf (extent-object value)
- a (extent-start-position value)
- b (extent-end-position value)))
- ((and (consp value)
- (markerp (car value))
- (markerp (cdr value)))
- (setq a (marker-position (car value))
- b (marker-position (cdr value))
- buf (marker-buffer (car value)))))
- (save-excursion
- (set-buffer buf)
- (save-restriction
- (widen)
- (goto-char a)
- (beginning-of-line)
- (setq a (1+ (count-lines 1 (point))))
- (goto-char b)
- (beginning-of-line)
- (setq b (1+ (count-lines 1 (point))))))
- (if (< b a) (setq tmp a a b b tmp))
- (cons 'SPAN
- (vector (cons (ash a -16) (logand a 65535))
- (cons (ash b -16) (logand b 65535))))))))
-
-(defun xselect-convert-to-colno (selection type value)
- (let (a b buf tmp)
- (cond ((cond ((extentp value)
- (setq buf (extent-object value)
- a (extent-start-position value)
- b (extent-end-position value)))
- ((and (consp value)
- (markerp (car value))
- (markerp (cdr value)))
- (setq a (car value)
- b (cdr value)
- buf (marker-buffer a))))
- (save-excursion
- (set-buffer buf)
- (goto-char a)
- (setq a (current-column))
- (goto-char b)
- (setq b (current-column)))
- (if (< b a) (setq tmp a a b b tmp))
- (cons 'SPAN
- (vector (cons (ash a -16) (logand a 65535))
- (cons (ash b -16) (logand b 65535))))))))
-
-(defun xselect-convert-to-sourceloc (selection type value)
- (let (a b buf file-name tmp)
- (cond ((cond ((extentp value)
- (setq buf (or (extent-object value)
- (error "selection is in a killed buffer"))
- a (extent-start-position value)
- b (extent-end-position value)
- file-name (buffer-file-name buf)))
- ((and (consp value)
- (markerp (car value))
- (markerp (cdr value)))
- (setq a (marker-position (car value))
- b (marker-position (cdr value))
- buf (or (marker-buffer (car value))
- (error "selection is in a killed buffer"))
- file-name (buffer-file-name buf))))
- (save-excursion
- (set-buffer buf)
- (save-restriction
- (widen)
- (goto-char a)
- (beginning-of-line)
- (setq a (1+ (count-lines 1 (point))))
- (goto-char b)
- (beginning-of-line)
- (setq b (1+ (count-lines 1 (point))))))
- (if (< b a) (setq tmp a a b b tmp))
- (format "%s:%d" file-name a)))))
-
-(defun xselect-convert-to-os (selection type size)
- (symbol-name system-type))
-
-(defun xselect-convert-to-host (selection type size)
- (system-name))
-
-(defun xselect-convert-to-user (selection type size)
- (user-full-name))
-
-(defun xselect-convert-to-class (selection type size)
- x-emacs-application-class)
-
-;; We do not try to determine the name Emacs was invoked with,
-;; because it is not clean for a program's behavior to depend on that.
-(defun xselect-convert-to-name (selection type size)
- ;invocation-name
- "xemacs")
-
-(defun xselect-convert-to-integer (selection type value)
- (and (integerp value)
- (cons (ash value -16) (logand value 65535))))
-
-(defun xselect-convert-to-atom (selection type value)
- (and (symbolp value) value))
-
-(defun xselect-convert-to-identity (selection type value) ; used internally
- (vector value))
-
-(setq selection-converter-alist
- '((TEXT . xselect-convert-to-text)
- (STRING . xselect-convert-to-string)
- (COMPOUND_TEXT . xselect-convert-to-compound-text)
- (TARGETS . xselect-convert-to-targets)
- (LENGTH . xselect-convert-to-length)
- (DELETE . xselect-convert-to-delete)
- (FILE_NAME . xselect-convert-to-filename)
- (CHARACTER_POSITION . xselect-convert-to-charpos)
- (SOURCE_LOC . xselect-convert-to-sourceloc)
- (LINE_NUMBER . xselect-convert-to-lineno)
- (COLUMN_NUMBER . xselect-convert-to-colno)
- (OWNER_OS . xselect-convert-to-os)
- (HOST_NAME . xselect-convert-to-host)
- (USER . xselect-convert-to-user)
- (CLASS . xselect-convert-to-class)
- (NAME . xselect-convert-to-name)
- (ATOM . xselect-convert-to-atom)
- (INTEGER . xselect-convert-to-integer)
- (_EMACS_INTERNAL . xselect-convert-to-identity)
- ))
;FSFmacs (provide 'select)
+1999-05-17 Jerry James <jerry@cs.ucsb.edu>
+
+ * xlwmenu.c (make_shadow_gcs): Test bottom_shadow_pixmap before
+ using it.
+
1999-05-14 XEmacs Build Bot <builds@cvs.xemacs.org>
* XEmacs 21.2.14 is released
xgcv.foreground = mw->menu.bottom_shadow_color;
/* xgcv.stipple = mw->menu.bottom_shadow_pixmap; gtb */
#ifdef NEED_MOTIF
- if (mw->menu.top_shadow_pixmap &&
- mw->menu.top_shadow_pixmap != XmUNSPECIFIED_PIXMAP)
+ if (mw->menu.bottom_shadow_pixmap &&
+ mw->menu.bottom_shadow_pixmap != XmUNSPECIFIED_PIXMAP)
xgcv.stipple = mw->menu.bottom_shadow_pixmap;
else
xgcv.stipple = 0;
+1999-05-30 Albert Chin-A-Young <china@thewrittenword.com>
+
+ * custom.texi, external-widget.texi: Minor
+ fix to get info DIR entry correct.
+
+1999-05-22 Vin Shelton <acs@xemacs.org>
+
+ * xemacs/cmdargs.texi:
+ Document -private.
+
+1999-05-16 Mike McEwan <mike@lotusland.demon.co.uk>
+
+ * Makefile: Added `emodules.info' to info targets.
+
+1999-05-20 Karl M. Hegbloom <karlheg@debian.org>
+
+ * internals/internals.texi (The XEmacs Object System
+ (Abstractly Speaking)): typo.
+
+1999-05-16 Hrvoje Niksic <hniksic@srce.hr>
+
+ * lispref/text.texi (Substitution): Document improvements in
+ `translate-region'.
+
1999-05-14 XEmacs Build Bot <builds@cvs.xemacs.org>
* XEmacs 21.2.14 is released
info_files = \
$(INFODIR)/cl.info \
$(INFODIR)/custom.info \
+ $(INFODIR)/emodules.info \
$(INFODIR)/external-widget.info \
$(INFODIR)/info.info \
$(INFODIR)/standards.info \
dvi_files = \
cl.dvi \
custom.dvi \
+ emodules.dvi \
external-widget.dvi \
info.dvi \
standards.dvi \
../info/custom.info : custom.texi
-$(MAKEINFO) custom.texi -o ../info/custom.info
+../info/emodules.info : emodules.texi
+ -$(MAKEINFO) emodules.texi -o ../info/emodules.info
+
../info/external-widget.info : external-widget.texi
-$(MAKEINFO) external-widget.texi -o ../info/external-widget.info
@dircategory XEmacs Editor
@direntry
* Customizations: (custom). Customization Library.
-package.
@end direntry
@end ifinfo
@dircategory XEmacs Editor
@direntry
* External Widget: (external-widget) External Client Widget.
-package.
@end direntry
@end ifinfo
@setfilename ../info/info.info
@settitle Info 1.0
@comment %**end of header
-@comment $Id: info.texi,v 1.4 1997/07/10 21:58:11 karl Exp $
+@comment $Id: info.texi,v 1.4 1998/06/30 06:35:28 steve Exp $
@dircategory Texinfo documentation system
@direntry
1.983e-4
@end example
-converts to a float whose value is 1983.23e-4, or .0001983.
+converts to a float whose value is 1.983e-4, or .0001983.
@example
?b
@defun translate-region start end table
This function applies a translation table to the characters in the
-buffer between positions @var{start} and @var{end}.
+buffer between positions @var{start} and @var{end}. The translation
+table @var{table} can be either a string, a vector, or a char-table.
-The translation table @var{table} is a string; @code{(aref @var{table}
-@var{ochar})} gives the translated character corresponding to
-@var{ochar}. If the length of @var{table} is less than 256, any
-characters with codes larger than the length of @var{table} are not
-altered by the translation.
+If @var{table} is a string, its @var{n}th element is the mapping for the
+character with code @var{n}.
+
+If @var{table} is a vector, its @var{n}th element is the mapping for
+character with code @var{n}. Legal mappings are characters, strings, or
+@code{nil} (meaning don't replace.)
+
+If @var{table} is a char-table, its elements describe the mapping
+between characters and their replacements. The char-table should be of
+type @code{char} or @code{generic}.
+
+When the @var{table} is a string or vector and its length is less than
+the total number of characters (256 without Mule), any characters with
+codes larger than the length of @var{table} are not altered by the
+translation.
The return value of @code{translate-region} is the number of
characters that were actually changed by the translation. This does
not count characters that were mapped into themselves in the
translation table.
+
+@strong{NOTE}: Prior to XEmacs 21.2, the @var{table} argument was
+allowed only to be a string. This is still the case in FSF Emacs.
+
+The following example creates a char-table that is passed to
+@code{translate-region}, which translates character @samp{a} to
+@samp{the letter a}, removes character @samp{b}, and translates
+character @samp{c} to newline.
+
+@example
+@group
+---------- Buffer: foo ----------
+Here is a sentence in the buffer.
+---------- Buffer: foo ----------
+@end group
+
+@group
+(let ((table (make-char-table 'generic)))
+ (put-char-table ?a "the letter a" table)
+ (put-char-table ?b "" table)
+ (put-char-table ?c ?\n table)
+ (translate-region (point-min) (point-max) table))
+ @result{} 3
+
+---------- Buffer: foo ----------
+Here is the letter a senten
+e in the uffer.
+---------- Buffer: foo ----------
+@end group
+@end example
@end defun
@node Registers
% texinfo.tex -- TeX macros to handle Texinfo files.
-% $Id: texinfo.tex,v 2.227 1998/02/25 22:54:34 karl Exp $
+% $Id: texinfo.tex,v 1.5 1998/06/13 04:28:12 steve Exp $
%
% Copyright (C) 1985, 86, 88, 90, 91, 92, 93, 94, 95, 96, 97, 98
% Free Software Foundation, Inc.
% This automatically updates the version number based on RCS.
\def\deftexinfoversion$#1: #2 ${\def\texinfoversion{#2}}
-\deftexinfoversion$Revision: 2.227 $
+\deftexinfoversion$Revision: 1.5 $
\message{Loading texinfo package [Version \texinfoversion]:}
% If in a .fmt file, print the version number
\input texinfo.tex @c -*-texinfo-*-
-@c $Id: texinfo.txi,v 1.50 1998/02/27 21:21:34 karl Exp $
+@c $Id: texinfo.texi,v 1.8.2.1 1999/03/04 15:48:24 steveb Exp $
@c %**start of header
@c All text is ignored before the setfilename.
@finalout
@titlepage
@title XEmacs FAQ
-@subtitle Frequently asked questions about XEmacs @* Last Modified: $Date: 1999/03/04 15:48:25 $
+@subtitle Frequently asked questions about XEmacs @* Last Modified: $Date: 1999/05/13 12:26:40 $
@sp 1
@author Tony Rossini <arossini@@stat.sc.edu>
@author Ben Wing <wing@@666.com>
@item -cr @var{color}
Use @var{color} as the text-cursor foreground color.
+
+@item -private
+Install a private colormap for XEmacs.
@end table
In addition, XEmacs allows you to use a number of standard Xt
+1999-05-31 Andy Piper <andy@xemacs.org>
+
+ * xemacs.mak: add select & select-x targets.
+
1999-05-14 XEmacs Build Bot <builds@cvs.xemacs.org>
* XEmacs 21.2.14 is released
$(XEMACS)\src\regex.c \
$(XEMACS)\src\scrollbar.c \
$(XEMACS)\src\search.c \
+ $(XEMACS)\src\select.c \
$(XEMACS)\src\signal.c \
$(XEMACS)\src\sound.c
DOC_SRC5=\
$(XEMACS)\src\balloon-x.c \
$(XEMACS)\src\xgccache.c \
$(XEMACS)\src\xmu.c \
- $(XEMACS)\src\xselect.c
+ $(XEMACS)\src\select-x.c
!endif
!if $(HAVE_MSW)
$(OUTDIR)\scrollbar-x.obj \
$(OUTDIR)\xgccache.obj \
$(OUTDIR)\xmu.obj \
- $(OUTDIR)\xselect.obj
+ $(OUTDIR)\select-x.obj
!endif
!if $(HAVE_MSW)
$(OUTDIR)\regex.obj \
$(OUTDIR)\scrollbar.obj \
$(OUTDIR)\search.obj \
+ $(OUTDIR)\select.obj \
$(OUTDIR)\signal.obj \
$(OUTDIR)\sound.obj \
$(OUTDIR)\specifier.obj \
cd ../lwlib && $(RECURSIVE_MAKE)
x_objs=balloon_help.o balloon-x.o console-x.o device-x.o event-Xt.o frame-x.o\
- glyphs-x.o objects-x.o redisplay-x.o xgccache.o xselect.o
+ glyphs-x.o objects-x.o redisplay-x.o select-x.o xgccache.o
#ifdef AIX4
LIBI18N = -li18n
macros.o marker.o md5.o minibuf.o objects.o opaque.o\
print.o process.o profile.o\
rangetab.o redisplay.o redisplay-output.o regex.o\
- search.o $(sheap_obj) signal.o sound.o\
+ search.o select.o $(sheap_obj) signal.o sound.o\
specifier.o strftime.o symbols.o syntax.o sysdep.o\
undo.o $(x_objs) widget.o window.o
#endif /* ! defined (CANNOT_DUMP) */
${PROGNAME}: temacs ${libsrc}DOC $(mo_file) ${other_files} update-elc.stamp
+#ifdef HEAP_IN_DATA
+ @$(RM) $@ $@.exe && touch SATISFIED
+ -${dump_temacs}
+ @if test -f $@; then if test -f SATISFIED; then \
+ echo "Testing for Lisp shadows ..."; \
+ ./${PROGNAME} -batch -vanilla -f list-load-path-shadows; fi; \
+ $(RM) SATISFIED; exit 0; fi; \
+ if test -f SATISFIED; then $(RM) SATISFIED; exit 1; fi; \
+ $(RECURSIVE_MAKE) $@;
+#else
@$(RM) $@
-${dump_temacs}
@echo "Testing for Lisp shadows ..."
@./${PROGNAME} -batch -vanilla -f list-load-path-shadows
+#endif
fastdump: temacs
@$(RM) ${PROGNAME} && touch SATISFIED
extern Lisp_Object Qand_rest, Qand_optional;
-/* Define ERROR_CHECK_BYTE_CODE to enable some minor sanity checking.
- Useful for debugging the byte compiler. */
-#ifdef DEBUG_XEMACS
-#define ERROR_CHECK_BYTE_CODE
-#endif
-
/* Define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
This isn't defined in FSF Emacs and isn't defined in XEmacs v19. */
/* #define BYTE_CODE_METER */
{
defsymbol (&Qinit_pre_mswindows_win, "init-pre-mswindows-win");
defsymbol (&Qinit_post_mswindows_win, "init-post-mswindows-win");
-
- DEFVAR_LISP ("mswindows-downcase-file-names", &Vmswindows_downcase_file_names /*
-Non-nil means convert all-upper case file names to lower case.
-This applies when performing completions and file name expansion.
-*/ );
- Vmswindows_downcase_file_names = Qnil;
-
- DEFVAR_LISP ("mswindows-get-true-file-attributes", &Vmswindows_get_true_file_attributes /*
-Non-nil means determine accurate link count in file-attributes.
-This option slows down file-attributes noticeably, so is disabled by
-default. Note that it is only useful for files on NTFS volumes,
-where hard links are supported.
-*/ );
- Vmswindows_get_true_file_attributes = Qnil;
}
void
void
vars_of_device_mswindows (void)
{
+ DEFVAR_LISP ("mswindows-downcase-file-names", &Vmswindows_downcase_file_names /*
+Non-nil means convert all-upper case file names to lower case.
+This applies when performing completions and file name expansion.
+*/ );
+ Vmswindows_downcase_file_names = Qnil;
+
+ DEFVAR_LISP ("mswindows-get-true-file-attributes", &Vmswindows_get_true_file_attributes /*
+Non-nil means determine accurate link count in file-attributes.
+This option slows down file-attributes noticeably, so is disabled by
+default. Note that it is only useful for files on NTFS volumes,
+where hard links are supported.
+*/ );
+ Vmswindows_get_true_file_attributes = Qnil;
}
XtRealizeWidget (app_shell);
}
-#ifdef HAVE_SESSION
+#ifdef HAVE_WMCOMMAND
{
int new_argc;
char **new_argv;
XSetCommand (XtDisplay (app_shell), XtWindow (app_shell), new_argv, new_argc);
free_argc_argv (new_argv);
}
-#endif /* HAVE_SESSION */
+#endif /* HAVE_WMCOMMAND */
#ifdef HAVE_OFFIX_DND
XSetClassHint (dpy, XtWindow (shell), &classhint);
}
-#ifndef HAVE_SESSION
+#ifndef HAVE_WMCOMMAND
static void
x_wm_maybe_store_wm_command (struct frame *f)
{
}
}
-#endif /* !HAVE_SESSION */
+#endif /* !HAVE_WMCOMMAND */
static int
x_frame_iconified_p (struct frame *f)
/* tell the window manager about us. */
x_wm_store_class_hints (shell_widget, XtName (frame_widget));
-#ifndef HAVE_SESSION
+#ifndef HAVE_WMCOMMAND
x_wm_maybe_store_wm_command (f);
-#endif /* HAVE_SESSION */
+#endif /* HAVE_WMCOMMAND */
x_wm_hack_wm_protocols (shell_widget);
}
{
Display *dpy;
-#ifndef HAVE_SESSION
+#ifndef HAVE_WMCOMMAND
if (FRAME_X_TOP_LEVEL_FRAME_P (f))
x_wm_maybe_move_wm_command (f);
-#endif /* HAVE_SESSION */
+#endif /* HAVE_WMCOMMAND */
#ifdef HAVE_CDE
DtDndDropUnregister (FRAME_X_TEXT_WIDGET (f));
#ifdef LINUX
- # define SYSTEM_MALLOC
+# define SYSTEM_MALLOC
#endif
#ifdef OSF1
void
syms_of_ntproc ()
{
- Qhigh = intern ("high");
- Qlow = intern ("low");
-
DEFSUBR (Fwin32_short_file_name);
DEFSUBR (Fwin32_long_file_name);
DEFSUBR (Fwin32_set_process_priority);
DEFSUBR (Fwin32_get_default_locale_id);
DEFSUBR (Fwin32_get_valid_locale_ids);
DEFSUBR (Fwin32_set_current_locale);
+}
+
+
+void
+vars_of_ntproc (void)
+{
+ Qhigh = intern ("high");
+ Qlow = intern ("low");
DEFVAR_LISP ("win32-quote-process-args", &Vwin32_quote_process_args /*
Non-nil enables quoting of process arguments to ensure correct parsing.
subprocess group, but may allow Emacs to interrupt a subprocess that doesn't
otherwise respond to interrupts from Emacs.
*/ );
- Vwin32_start_process_share_console = Qnil;
+ Vwin32_start_process_share_console = Qt;
DEFVAR_LISP ("win32-pipe-read-delay", &Vwin32_pipe_read_delay /*
Forced delay before reading subprocess output.
Vwin32_generate_fake_inodes = Qnil;
#endif
}
+
/* end of ntproc.c */
faster.
BUFFER should accept 24 bytes. This should suffice for the longest
- numbers on 64-bit machines. */
+ numbers on 64-bit machines, including the `-' sign and the trailing
+ \0. */
void
long_to_string (char *buffer, long number)
{
- char *p;
- int i, len;
+#if (SIZEOF_LONG != 4) && (SIZEOF_LONG != 8)
+ /* Huh? */
+ sprintf (buffer, "%ld", number);
+#else /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
+ char *p = buffer;
+ int force = 0;
if (number < 0)
{
- *buffer++ = '-';
+ *p++ = '-';
number = -number;
}
- p = buffer;
- /* Print the digits to the string. */
- do
- {
- *p++ = number % 10 + '0';
- number /= 10;
- }
- while (number);
-
- /* And reverse them. */
- len = p - buffer - 1;
- for (i = len / 2; i >= 0; i--)
- {
- char c = buffer[i];
- buffer[i] = buffer[len - i];
- buffer[len - i] = c;
- }
- buffer[len + 1] = '\0';
+#define FROB(figure) do { \
+ if (force || number >= figure) \
+ *p++ = number / figure + '0', number %= figure, force = 1; \
+ } while (0)
+#if SIZEOF_LONG == 8
+ FROB (1000000000000000000L);
+ FROB (100000000000000000L);
+ FROB (10000000000000000L);
+ FROB (1000000000000000L);
+ FROB (100000000000000L);
+ FROB (10000000000000L);
+ FROB (1000000000000L);
+ FROB (100000000000L);
+ FROB (10000000000L);
+#endif /* SIZEOF_LONG == 8 */
+ FROB (1000000000);
+ FROB (100000000);
+ FROB (10000000);
+ FROB (1000000);
+ FROB (100000);
+ FROB (10000);
+ FROB (1000);
+ FROB (100);
+ FROB (10);
+#undef FROB
+ *p++ = number + '0';
+ *p = '\0';
+#endif /* (SIZEOF_LONG == 4) || (SIZEOF_LONG == 8) */
}
\f
static void
#define regoff_t sys_regoff_t
#define regmatch_t sys_regmatch_t
-/* A perfectly ordinary link wins again - martin */
+/* A perfectly ordinary link wins again - martin
#undef C_SWITCH_SYSTEM
#undef LIBS_SYSTEM
#undef LIBS_DEBUG
-#define ORDINARY_LINK
+#define ORDINARY_LINK */
-#define SYSTEM_MALLOC
+/*#define SYSTEM_MALLOC*/
#if 0 /* martin */
/* Some V4.0* versions before V4.0B don't detect rename properly. */
#include <config.h>
#include "lisp.h"
+#include "select.h"
#include "console-msw.h"
return i ? Qt : Qnil;
}
+/* Do protocol to assert ourself as a selection owner. Under mswindows
+this is easy, we just set the clipboard. */
+static Lisp_Object
+mswindows_own_selection (Lisp_Object selection_name, Lisp_Object selection_value)
+{
+ Lisp_Object converted_value = get_local_selection (selection_name, QSTRING);
+ if (!NILP (converted_value) &&
+ CONSP (converted_value) &&
+ EQ (XCAR (converted_value), QSTRING))
+ Fmswindows_set_clipboard (XCDR (converted_value));
+
+ return Qnil;
+}
+
DEFUN ("mswindows-get-clipboard", Fmswindows_get_clipboard, 0, 0, 0, /*
Return the contents of the mswindows clipboard.
*/
return ret;
}
+static Lisp_Object
+mswindows_get_foreign_selection (Lisp_Object selection_symbol, Lisp_Object target_type)
+{
+ return Fmswindows_get_clipboard ();
+}
+
DEFUN ("mswindows-selection-exists-p", Fmswindows_selection_exists_p, 0, 0, 0, /*
Whether there is an MS-Windows selection.
*/
return EmptyClipboard () ? Qt : Qnil;
}
+static void
+mswindows_disown_selection (Lisp_Object selection, Lisp_Object timeval)
+{
+ Fmswindows_delete_selection ();
+}
+
\f
/************************************************************************/
/* initialization */
/************************************************************************/
void
+console_type_create_select_mswindows (void)
+{
+ CONSOLE_HAS_METHOD (mswindows, own_selection);
+ CONSOLE_HAS_METHOD (mswindows, disown_selection);
+ CONSOLE_HAS_METHOD (mswindows, get_foreign_selection);
+}
+
+void
syms_of_select_mswindows (void)
{
DEFSUBR (Fmswindows_set_clipboard);
#include <unistd.h>
#include <sheap-adjust.h>
-#define STATIC_HEAP_BASE 0x600000
+#define STATIC_HEAP_BASE 0x800000
#define STATIC_HEAP_SLOP 0x40000
#define STATIC_HEAP_SIZE \
(STATIC_HEAP_BASE + SHEAP_ADJUSTMENT + STATIC_HEAP_SLOP)
return result;
}
-void
+static void
sheap_adjust_h ()
{
FILE *stream = fopen ("sheap-adjust.h", "w");
fclose (stream);
}
+void
+report_sheap_usage (int die_if_pure_storage_exceeded)
+{
+ int rc = 0;
+
+ size_t lost = (STATIC_HEAP_BASE + STATIC_HEAP_SLOP + SHEAP_ADJUSTMENT)
+ - (static_heap_ptr - static_heap_buffer);
+ char buf[200];
+ sprintf (buf, "Static heap usage: %ld of %ld",
+ (long) (static_heap_ptr - static_heap_buffer),
+ (long) (STATIC_HEAP_BASE + STATIC_HEAP_SLOP + SHEAP_ADJUSTMENT));
+
+ if (lost > STATIC_HEAP_SLOP) {
+ sprintf (buf + strlen (buf), " -- %ldk wasted", (long)(lost/1024));
+ if (die_if_pure_storage_exceeded) {
+ sheap_adjust_h();
+ rc = -1;
+ }
+ message ("%s", buf);
+ }
+
+ if (rc < 0) {
+ unlink("SATISFIED");
+ fatal ("Static heap size adjusted, Don't Panic! I will restart the `make'");
+ }
+}
+
+
internal_hash (get_toolbar_button_glyph(w, tb), 0),
internal_hash (tb->callback, 0),
width,
- w->toolbar_buttons_captioned_p);
+ LISP_HASH (w->toolbar_buttons_captioned_p));
button = tb->next;
nbuttons++;
}
/* Synched up with: Not in FSF. */
-/* #pragma ident "@(#) $Id: unexsol2.c,v 1.2 1995/01/25 20:39:16 georgn Exp $" */
+/* #pragma ident "@(#) $Id: unexsol2.c,v 1.3 1997/10/13 03:35:33 steve Exp $" */
#include <stdlib.h>
#include <stdio.h>
+1999-05-27 Hrvoje Niksic <hniksic@srce.hr>
+
+ * automated/base64-tests.el: New file.
+
1999-05-14 XEmacs Build Bot <builds@cvs.xemacs.org>
* XEmacs 21.2.14 is released
#!/bin/sh
+emacs_is_beta=t
emacs_major_version=21
emacs_minor_version=2
emacs_beta_version=14
projects / chise / xemacs-chise.git / commitdiff