If the property value is @code{t}, the newline character has no
effect on the displayed height of the line---the visible contents
- alone determine the height. This is useful for tiling small images
- (or image slices) without adding blank areas between the images.
+ alone determine the height. The @code{line-spacing} property,
+ described below, is also ignored in this case. This is useful for
+ tiling small images (or image slices) without adding blank areas
+ between the images.
If the property value is a list of the form @code{(@var{height}
@var{total})}, that adds extra space @emph{below} the display line.
First Emacs uses @var{height} as a height spec to control extra space
@emph{above} the line; then it adds enough space @emph{below} the line
- to bring the total line height up to @var{total}. In this case, the
- other ways to specify the line spacing are ignored.
+ to bring the total line height up to @var{total}. In this case, any
+ value of @code{line-spacing} property for the newline is ignored.
@cindex height spec
Any other kind of property value is a height spec, which translates
@kindex line-spacing @r{(text property)}
Finally, a newline can have a @code{line-spacing} text or overlay
- property that overrides the default frame line spacing and the buffer
- local @code{line-spacing} variable, for the display line ending in
- that newline.
+ property that can enlarge the default frame line spacing and the
+ buffer local @code{line-spacing} variable: if its value is larger than
+ the buffer or frame defaults, that larger value is used instead, for
+ the display line ending in that newline.
One way or another, these mechanisms specify a Lisp value for the
spacing of each line. The value is a height spec, and it translates
@itemx bold-italic
@itemx underline
@itemx fixed-pitch
+@itemx fixed-pitch-serif
@itemx variable-pitch
These have the attributes indicated by their names (e.g., @code{bold}
has a bold @code{:weight} attribute), with all other attributes
* XPM Images:: Special features for XPM format.
* PostScript Images:: Special features for PostScript format.
* ImageMagick Images:: Special features available through ImageMagick.
+* SVG Images:: Creating and manipulating SVG images.
* Other Image Types:: Various other formats are supported.
* Defining Images:: Convenient ways to define an image for later use.
* Showing Images:: Convenient ways to display an image once it is defined.
@cindex ImageMagick images
@cindex images, support for more formats
- If you build Emacs with ImageMagick support, you can use the
+ If your Emacs build has ImageMagick support, you can use the
ImageMagick library to load many image formats (@pxref{File
Conveniences,,, emacs, The GNU Emacs Manual}). The image type symbol
for images loaded via ImageMagick is @code{imagemagick}, regardless of
the actual underlying image format.
+To check for ImageMagick support, use the following:
+
+@lisp
+(image-type-available-p 'imagemagick)
+@end lisp
+
@defun imagemagick-types
This function returns a list of image file extensions supported by the
current ImageMagick installation. Each list element is a symbol
wish. @code{:max-width} and @code{:max-height} will always preserve
the aspect ratio.
+@item :scale @var{scale}
+This should be a number, where values higher than 1 means to increase
+the size, and lower means to decrease the size. For instance, a value
+of 0.25 will make the image a quarter size of what it originally was.
+If the scaling makes the image larger than specified by
+@code{:max-width} or @code{:max-height}, the resulting size will not
+exceed those two values. If both @code{:scale} and
+@code{:height}/@code{:width} are specified, the height/width will be
+adjusted by the specified scaling factor.
+
@item :format @var{type}
The value, @var{type}, should be a symbol specifying the type of the
image data, as found in @code{image-format-suffixes}. This is used
@xref{Multi-Frame Images}.
@end table
+@node SVG Images
+@subsection SVG Images
+@cindex SVG images
+
+SVG (Scalable Vector Graphics) is an XML format for specifying images.
+If your Emacs build has with SVG support, you can create and manipulate
+these images with the following commands.
+
+@defun svg-create width height &rest args
+Create a new, empty SVG image with the specified dimensions.
+@var{args} is an argument plist with you can specify following:
+
+@table @code
+@item :stroke-width
+The default width (in pixels) of any lines created.
+
+@item :stroke
+The default stroke color on any lines created.
+@end table
+
+This function returns an SVG structure, and all the following commands
+work on that structure.
+@end defun
+
+@defun svg-gradient svg id type stops
+Create a gradient in @var{svg} with identifier @var{id}. @var{type}
+specifies the gradient type, and can be either @code{linear} or
+@code{radial}. @var{stops} is a list of percentage/color pairs.
+
+The following will create a linear gradient that goes from red at the
+start, to green 25% of the way, to blue at the end:
+
+@lisp
+(svg-gradient svg "gradient1" 'linear
+ '((0 . "red") (25 . "green") (100 . "blue")))
+@end lisp
+
+The gradient created (and inserted into the SVG object) can later be
+used by all functions that create shapes.
+@end defun
+
+All the following functions take an optional list of keyword
+parameters that alter the various attributes from their default
+values. Valid attributes include:
+
+@table @code
+@item :stroke-width
+The width (in pixels) of lines drawn, and outlines around solid
+shapes.
+
+@item :stroke-color
+The color of lines drawn, and outlines around solid shapes.
+
+@item :fill-color
+The color used for solid shapes.
+
+@item :id
+The identified of the shape.
+
+@item :gradient
+If given, this should be the identifier of a previously defined
+gradient object.
+@end table
+
+@defun svg-rectangle svg x y width height &rest args
+Add a rectangle to @var{svg} where the upper left corner is at
+position @var{x}/@var{y} and is of size @var{width}/@var{height}.
+
+@lisp
+(svg-rectangle svg 100 100 500 500 :gradient "gradient1")
+@end lisp
+@end defun
+
+@defun svg-circle svg x y radius &rest args
+Add a circle to @var{svg} where the center is at @var{x}/@var{y}
+and the radius is @var{radius}.
+@end defun
+
+@defun svg-ellipse svg x y x-radius y-radius &rest args
+Add a circle to @var{svg} where the center is at @var{x}/@var{y} and
+the horizontal radius is @var{x-radius} and the vertical radius is
+@var{y-radius}.
+@end defun
+
+@defun svg-line svg x1 y1 x2 y2 &rest args
+Add a line to @var{svg} that starts at @var{x1}/@var{y1} and extends
+to @var{x2}/@var{y2}.
+@end defun
+
+@defun svg-polyline svg points &rest args
+Add a multiple segment line to @var{svg} that goes through
+@var{points}, which is a list of X/Y position pairs.
+
+@lisp
+(svg-polyline svg '((200 . 100) (500 . 450) (80 . 100))
+ :stroke-color "green")
+@end lisp
+@end defun
+
+@defun svg-polygon svg points &rest args
+Add a polygon to @var{svg} where @var{points} is a list of X/Y pairs
+that describe the outer circumference of the polygon.
+
+@lisp
+(svg-polygon svg '((100 . 100) (200 . 150) (150 . 90))
+ :stroke-color "blue" :fill-color "red"")
+@end lisp
+@end defun
+
+Finally, the @code{svg-image} takes an SVG object as its parameter and
+returns an image object suitable for use in functions like
+@code{insert-image}. Here's a complete example that creates and
+inserts an image with a circle:
+
+@lisp
+(let ((svg (svg-create 400 400 :stroke-width 10)))
+ (svg-gradient svg "gradient1" 'linear '((0 . "red") (100 . "blue")))
+ (svg-circle svg 200 200 100 :gradient "gradient1" :stroke-color "green")
+ (insert-image (svg-image svg)))
+@end lisp
+
+
@node Other Image Types
@subsection Other Image Types
@cindex PBM
@item PNG
Image type @code{png}.
-@item SVG
-Image type @code{svg}.
-
@item TIFF
Image type @code{tiff}.
Supports the @code{:index} property. @xref{Multi-Frame Images}.
as @code{nil}.
@end defmac
+@defun image-property image property
+Return the value of @var{property} in @var{image}. Properties can be
+set by using @code{setf}. Setting a property to @code{nil} will
+remove the property from the image.
+@end defun
+
@defun find-image specs
This function provides a convenient way to find an image satisfying one
of a list of image specifications @var{specs}.
@end example
@end defun
+@vindex image-scaling-factor
+Images are automatically scaled when created based on the
+@code{image-scaling-factor} variable. The value is either a floating
+point number (where numbers higher than 1 means to increase the size
+and lower means to shrink the size), or the symbol @code{auto}, which
+will compute a scaling factor based on the font pixel size.
+
@node Showing Images
@subsection Showing Images
@cindex show image
@code{max-image-size} is subsequently changed (@pxref{Image Cache}).
@end defvar
+Images inserted with the insertion functions above also get a local
+keymap installed in the text properties (or overlays) that span the
+displayed image. This keymap defines the following commands:
+
+@table @kbd
+@item +
+Increase the image size (@code{image-increase-size}). A prefix value
+of @samp{4} means to increase the size by 40%. The default is 20%.
+
+@item -
+Decrease the image size (@code{image-increase-size}). A prefix value
+of @samp{4} means to decrease the size by 40%. The default is 20%.
+
+@item r
+Rotate the image by 90 degrees (@code{image-rotate}).
+
+@item o
+Save the image to a file (@code{image-save}).
+@end table
+
@node Multi-Frame Images
@subsection Multi-Frame Images
@cindex multi-frame images
Each major mode should have a normal @dfn{mode hook} named
@code{@var{modename}-mode-hook}. The very last thing the major mode command
should do is to call @code{run-mode-hooks}. This runs the normal
-hook @code{change-major-mode-after-body-hook}, the mode hook,
+hook @code{change-major-mode-after-body-hook}, the mode hook, the
+function @code{hack-local-variables} (when the buffer is visiting a file),
and then the normal hook @code{after-change-major-mode-hook}.
@xref{Mode Hooks}.
It also processes local variables specified in the file text.
@deffn Command normal-mode &optional find-file
-This function establishes the proper major mode and buffer-local variable
-bindings for the current buffer. First it calls @code{set-auto-mode}
-(see below), then it runs @code{hack-local-variables} to parse, and
-bind or evaluate as appropriate, the file's local variables
-(@pxref{File Local Variables}).
+This function establishes the proper major mode and buffer-local
+variable bindings for the current buffer. It calls
+@code{set-auto-mode} (see below). As from Emacs 25.2, it no longer
+runs @code{hack-local-variables}, this now being done in
+@code{run-mode-hooks} at the initialization of major modes
+(@pxref{Mode Hooks}).
If the @var{find-file} argument to @code{normal-mode} is non-@code{nil},
@code{normal-mode} assumes that the @code{find-file} function is calling
@var{find-file} is normally @code{nil}. In this case,
@code{normal-mode} unconditionally processes any file local variables.
-The function calls @code{set-auto-mode} to choose a major mode. If this
-does not specify a mode, the buffer stays in the major mode determined
-by the default value of @code{major-mode} (see below).
+The function calls @code{set-auto-mode} to choose and set a major
+mode. If this does not specify a mode, the buffer stays in the major
+mode determined by the default value of @code{major-mode} (see below).
@cindex file mode specification error
@code{normal-mode} uses @code{condition-case} around the call to the
@defun set-auto-mode &optional keep-mode-if-same
@cindex visited file mode
- This function selects the major mode that is appropriate for the
-current buffer. It bases its decision (in order of precedence) on the
-@w{@samp{-*-}} line, on any @samp{mode:} local variable near the end of
-a file, on the @w{@samp{#!}} line (using @code{interpreter-mode-alist}),
-on the text at the beginning of the buffer (using
-@code{magic-mode-alist}), and finally on the visited file name (using
-@code{auto-mode-alist}). @xref{Choosing Modes, , How Major Modes are
-Chosen, emacs, The GNU Emacs Manual}. If @code{enable-local-variables}
-is @code{nil}, @code{set-auto-mode} does not check the @w{@samp{-*-}}
-line, or near the end of the file, for any mode tag.
+ This function selects and sets the major mode that is appropriate
+for the current buffer. It bases its decision (in order of
+precedence) on the @w{@samp{-*-}} line, on any @samp{mode:} local
+variable near the end of a file, on the @w{@samp{#!}} line (using
+@code{interpreter-mode-alist}), on the text at the beginning of the
+buffer (using @code{magic-mode-alist}), and finally on the visited
+file name (using @code{auto-mode-alist}). @xref{Choosing Modes, , How
+Major Modes are Chosen, emacs, The GNU Emacs Manual}. If
+@code{enable-local-variables} is @code{nil}, @code{set-auto-mode} does
+not check the @w{@samp{-*-}} line, or near the end of the file, for
+any mode tag.
@vindex inhibit-local-variables-regexps
There are some file types where it is not appropriate to scan the file
@item
The new mode has its own mode hook, @code{@var{variant}-hook}. It
runs this hook, after running the hooks of its ancestor modes, with
-@code{run-mode-hooks}, as the last thing it does. @xref{Mode Hooks}.
+@code{run-mode-hooks}, as the last thing it does, apart from running
+any @code{:after-hook} form it may have. @xref{Mode Hooks}.
@end itemize
In addition, you can specify how to override other aspects of
documentation string. If you omit @var{docstring},
@code{define-derived-mode} generates a documentation string.
-The @var{keyword-args} are pairs of keywords and values. The values
-are evaluated. The following keywords are currently supported:
+The @var{keyword-args} are pairs of keywords and values. The values,
+except for @code{:after-hook}'s, are evaluated. The following
+keywords are currently supported:
@table @code
@item :syntax-table
@item :group
If this is specified, the value should be the customization group for
- this mode. (Not all major modes have one.) Only the (still
- experimental and unadvertised) command @code{customize-mode} currently
- uses this. @code{define-derived-mode} does @emph{not} automatically
- define the specified customization group.
+ this mode. (Not all major modes have one.) The command
+ @code{customize-mode} uses this. @code{define-derived-mode} does
+ @emph{not} automatically define the specified customization group.
+
+@item :after-hook
+This optional keyword specifies a single Lisp form to evaluate as the
+final act of the mode function, after the mode hooks have been run.
+It should not be quoted. Since the form might be evaluated after the
+mode function has terminated, it should not access any element of the
+mode function's local state. An @code{:after-hook} form is useful for
+setting up aspects of the mode which depend on the user's settings,
+which in turn may have been changed in a mode hook.
@end table
Here is a hypothetical example:
@defun run-mode-hooks &rest hookvars
Major modes should run their mode hook using this function. It is
similar to @code{run-hooks} (@pxref{Hooks}), but it also runs
-@code{change-major-mode-after-body-hook} and
-@code{after-change-major-mode-hook}.
+@code{change-major-mode-after-body-hook}, @code{hack-local-variables}
+(when the buffer is visiting a file) (@pxref{File Local Variables}),
+and @code{after-change-major-mode-hook}. The last thing it does is to
+evaluate any @code{:after-hook} forms declared by parent modes
+(@pxref{Derived Modes}).
When this function is called during the execution of a
-@code{delay-mode-hooks} form, it does not run the hooks immediately.
+@code{delay-mode-hooks} form, it does not run the hooks or
+@code{hack-local-variables} or evaluate the forms immediately.
Instead, it arranges for the next call to @code{run-mode-hooks} to run
them.
@end defun
behaves like @code{string-lessp}.
@end defun
+@defun string-version-lessp string1 string2
+This function compares strings lexicographically, except it treats
+sequences of numerical characters as if they comprised a base-ten
+number, and then compares the numbers. So @samp{foo2.png} is
+``smaller'' than @samp{foo12.png} according to this predicate, even if
+@samp{12} is lexicographically ``smaller'' than @samp{2}.
+@end defun
+
@defun string-prefix-p string1 string2 &optional ignore-case
This function returns non-@code{nil} if @var{string1} is a prefix of
@var{string2}; i.e., if @var{string2} starts with @var{string1}. If
For instance, @var{str1} is considered less than @var{str2} if
its first differing character has a smaller numeric value. If
@var{ignore-case} is non-@code{nil}, characters are converted to
- lower-case before comparing them. Unibyte strings are converted to
+ upper-case before comparing them. Unibyte strings are converted to
multibyte for comparison (@pxref{Text Representations}), so that a
unibyte string and its conversion to multibyte are always regarded as
equal.
This function works like @code{assoc}, except that @var{key} must be a
string or symbol, and comparison is done using @code{compare-strings}.
Symbols are converted to strings before testing.
- If @var{case-fold} is non-@code{nil}, it ignores case differences.
+ If @var{case-fold} is non-@code{nil}, @var{key} and the elements of
+ @var{alist} are converted to upper-case before comparison.
Unlike @code{assoc}, this function can also match elements of the alist
that are strings or symbols rather than conses. In particular, @var{alist} can
be a list of strings or symbols rather than an actual alist.
The characters in @var{string}, other than the format specifications,
are copied directly into the output, including their text properties,
-if any.
+if any. Any text properties of the format specifications are copied
+to the produced string representations of the argument @var{objects}.
@end defun
@defun format-message string &rest objects
@cindex curved quotes
@cindex curly quotes
This function acts like @code{format}, except it also converts any
-curved single quotes in @var{string} as per the value of
-@code{text-quoting-style}, and treats grave accent (@t{`}) and
-apostrophe (@t{'}) as if they were curved single quotes.
+grave accents (@t{`}) and apostrophes (@t{'}) in @var{string} as per the
+value of @code{text-quoting-style}.
A format that quotes with grave accents and apostrophes @t{`like
this'} typically generates curved quotes @t{‘like this’}. In
;;;###autoload
(defun customize-mode (mode)
- "Customize options related to the current major mode.
- If a prefix \\[universal-argument] was given (or if the current major mode has no known group),
- then prompt for the MODE to customize."
+ "Customize options related to a major or minor mode.
+ By default the current major mode is used. With a prefix
+ argument or if the current major mode has no known group, prompt
+ for the MODE to customize."
(interactive
(list
(let ((completion-regexp-list '("-mode\\'"))
major-mode
(intern
(completing-read (if group
- (format "Major mode (default %s): " major-mode)
- "Major mode: ")
+ (format "Mode (default %s): " major-mode)
+ "Mode: ")
obarray
'custom-group-of-mode
t nil nil (if group (symbol-name major-mode))))))))
(unless (eq symbol basevar)
(message "`%s' is an alias for `%s'" symbol basevar))))
-(defvar customize-changed-options-previous-release "24.1"
+(defvar customize-changed-options-previous-release "24.5"
"Version for `customize-changed-options' to refer back to by default.")
;; Packages will update this variable, so make it available.
buf))))
;;;###autoload
-(defun custom-buffer-create (options &optional name description)
+(defun custom-buffer-create (options &optional name _description)
"Create a buffer containing OPTIONS.
Optional NAME is the name of the buffer.
OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where
SYMBOL is a customization option, and WIDGET is a widget for editing
that option.
DESCRIPTION is unused."
- (pop-to-buffer-same-window (custom-get-fresh-buffer (or name "*Customization*")))
- (custom-buffer-create-internal options description))
+ (pop-to-buffer-same-window
+ (custom-get-fresh-buffer (or name "*Customization*")))
+ (custom-buffer-create-internal options))
;;;###autoload
-(defun custom-buffer-create-other-window (options &optional name description)
+(defun custom-buffer-create-other-window (options &optional name _description)
"Create a buffer containing OPTIONS, and display it in another window.
The result includes selecting that window.
Optional NAME is the name of the buffer.
OPTIONS should be an alist of the form ((SYMBOL WIDGET)...), where
SYMBOL is a customization option, and WIDGET is a widget for editing
-that option."
+that option.
+DESCRIPTION is unused."
(unless name (setq name "*Customization*"))
(switch-to-buffer-other-window (custom-get-fresh-buffer name))
- (custom-buffer-create-internal options description))
+ (custom-buffer-create-internal options))
(defcustom custom-reset-button-menu t
"If non-nil, only show a single reset button in customize buffers.
(eval-when-compile (require 'cl))
(autoload 'gnus-map-function "gnus-util")
-(autoload 'gnus-replace-in-string "gnus-util")
-(autoload 'gnus-read-shell-command "gnus-util")
-(autoload 'gnus-format-message "gnus-util")
(autoload 'mm-inline-partial "mm-partial")
(autoload 'mm-inline-external-body "mm-extern")
(mm-insert-part handle)
(let ((image
(ignore-errors
- (if (fboundp 'create-image)
- (create-image (buffer-string) 'imagemagick 'data-p)
- (mm-create-image-xemacs
- (mm-handle-media-subtype handle))))))
+ (create-image (buffer-string) 'imagemagick 'data-p))))
(when image
(setcar (cdr handle) (list "image/imagemagick"))
(mm-image-fit-p handle)))))))
:type '(repeat regexp) ;; See `mm-preferred-alternative-precedence'.
:group 'mime-display)
-(defcustom mm-tmp-directory
- (if (fboundp 'temp-directory)
- (temp-directory)
- (if (boundp 'temporary-file-directory)
- temporary-file-directory
- "/tmp/"))
+(defcustom mm-tmp-directory temporary-file-directory
"Where mm will store its temporary files."
:type 'directory
:group 'mime-display)
:group 'mime-display)
-(defvar mm-path-name-rewrite-functions nil
- "*List of functions for rewriting the full file names of MIME parts.
+(defcustom mm-path-name-rewrite-functions nil
+ "List of functions for rewriting the full file names of MIME parts.
This is used when viewing parts externally, and is meant for
transforming the absolute name so that non-compliant programs can find
the file where it's saved.
-Each function takes a file name as input and returns a file name.")
+Each function takes a file name as input and returns a file name."
+ :type '(repeat function)
+ :group 'mime-display)
(defvar mm-file-name-replace-whitespace nil
"String used for replacing whitespace characters; default is `\"_\"'.")
(with-current-buffer
(generate-new-buffer " *mm*")
;; Preserve the data's unibyteness (for url-insert-file-contents).
- (mm-set-buffer-multibyte mb)
+ (set-buffer-multibyte mb)
(insert-buffer-substring obuf beg)
(current-buffer))))
(concat
"using external program \""
(format method filename) "\"")
- (gnus-format-message
+ (format-message
"by calling `%s' on the contents)" method))
"? "))))))
(if external
(select-window win)))
(switch-to-buffer (generate-new-buffer " *mm*")))
(buffer-disable-undo)
- (mm-set-buffer-file-coding-system mm-binary-coding-system)
+ (set-buffer-file-coding-system mm-binary-coding-system)
(insert-buffer-substring cur)
(goto-char (point-min))
(when method
;; The function is a string to be executed.
(mm-insert-part handle)
(mm-add-meta-html-tag handle)
- (let* ((dir (mm-make-temp-file
+ (let* ((dir (make-temp-file
(expand-file-name "emm." mm-tmp-directory) 'dir))
(filename (or
(mail-content-type-get
;; `mailcap-mime-extensions'.
(setq suffix (car (rassoc (mm-handle-media-type handle)
mailcap-mime-extensions))))
- (setq file (mm-make-temp-file (expand-file-name "mm." dir)
- nil suffix))))
+ (setq file (make-temp-file (expand-file-name "mm." dir)
+ nil suffix))))
(let ((coding-system-for-write mm-binary-coding-system))
(write-region (point-min) (point-max) file nil 'nomesg))
;; The file is deleted after the viewer exists. If the users edits
(ignore-errors
(cond
;; Internally displayed part.
- ((mm-annotationp object)
- (if (featurep 'xemacs)
- (delete-annotation object)))
((or (functionp object)
(and (listp object)
(eq (car object) 'lambda)))
(with-current-buffer (mm-handle-buffer handle)
(buffer-string)))
((mm-multibyte-p)
- (mm-string-to-multibyte (mm-get-part handle no-cache)))
+ (string-to-multibyte (mm-get-part handle no-cache)))
(t
(mm-get-part handle no-cache)))))
(save-restriction
(defun mm-file-name-delete-control (filename)
"Delete control characters from FILENAME."
- (gnus-replace-in-string filename "[\x00-\x1f\x7f]" ""))
+ (replace-regexp-in-string "[\x00-\x1f\x7f]" "" filename))
(defun mm-file-name-delete-gotchas (filename)
"Delete shell gotchas from FILENAME."
- (setq filename (gnus-replace-in-string filename "[<>|]" ""))
- (gnus-replace-in-string filename "^[.-]+" ""))
+ (setq filename (replace-regexp-in-string "[<>|]" "" filename))
+ (replace-regexp-in-string "^[.-]+" "" filename))
(defun mm-save-part (handle &optional prompt)
"Write HANDLE to a file.
Use CMD as the process."
(let ((name (mail-content-type-get (mm-handle-type handle) 'name))
(command (or cmd
- (gnus-read-shell-command
+ (read-shell-command
"Shell command on MIME part: " mm-last-shell-command))))
(mm-with-unibyte-buffer
(mm-insert-part handle)
(prog1
(setq spec
(ignore-errors
- ;; Avoid testing `make-glyph' since W3 may define
- ;; a bogus version of it.
- (if (fboundp 'create-image)
- (create-image (buffer-string)
- (or (mm-image-type-from-buffer)
- (intern type))
- 'data-p)
- (mm-create-image-xemacs type))))
+ (create-image (buffer-string)
+ (or (mm-image-type-from-buffer)
+ (intern type))
+ 'data-p)))
(mm-handle-set-cache handle spec))))))
-(defun mm-create-image-xemacs (type)
- (when (featurep 'xemacs)
- (cond
- ((equal type "xbm")
- ;; xbm images require special handling, since
- ;; the only way to create glyphs from these
- ;; (without a ton of work) is to write them
- ;; out to a file, and then create a file
- ;; specifier.
- (let ((file (mm-make-temp-file
- (expand-file-name "emm" mm-tmp-directory)
- nil ".xbm")))
- (unwind-protect
- (progn
- (write-region (point-min) (point-max) file)
- (make-glyph (list (cons 'x file))))
- (ignore-errors
- (delete-file file)))))
- (t
- (make-glyph
- (vector
- (or (mm-image-type-from-buffer)
- (intern type))
- :data (buffer-string)))))))
-
(declare-function image-size "image.c" (spec &optional pixels frame))
(defun mm-image-fit-p (handle)
"Say whether the image in HANDLE will fit the current window."
(let ((image (mm-get-image handle)))
(or (not image)
- (if (featurep 'xemacs)
- ;; XEmacs's glyphs can actually tell us about their width, so
- ;; let's be nice and smart about them.
- (or mm-inline-large-images
- (and (<= (glyph-width image) (window-pixel-width))
- (<= (glyph-height image) (window-pixel-height))))
- (let* ((size (image-size image))
- (w (car size))
- (h (cdr size)))
- (or mm-inline-large-images
- (and (<= h (1- (window-height))) ; Don't include mode line.
- (<= w (window-width)))))))))
+ (let* ((size (image-size image))
+ (w (car size))
+ (h (cdr size)))
+ (or mm-inline-large-images
+ (and (<= h (1- (window-height))) ; Don't include mode line.
+ (<= w (window-width))))))))
(defun mm-valid-image-format-p (format)
"Say whether FORMAT can be displayed natively by Emacs."
- (cond
- ;; Handle XEmacs
- ((fboundp 'valid-image-instantiator-format-p)
- (valid-image-instantiator-format-p format))
- ;; Handle Emacs
- ((fboundp 'image-type-available-p)
- (and (display-graphic-p)
- (image-type-available-p format)))
- ;; Nobody else can do images yet.
- (t
- nil)))
+ (and (display-graphic-p)
+ (image-type-available-p format)))
(defun mm-valid-and-fit-image-p (format handle)
"Say whether FORMAT can be displayed natively and HANDLE fits the window."
(defun mm-shr (handle)
;; Require since we bind its variables.
(require 'shr)
- (let ((shr-width (if (and (boundp 'shr-use-fonts)
- shr-use-fonts)
+ (let ((shr-width (if shr-use-fonts
nil
fill-column))
(shr-content-function (lambda (id)
(mm-charset-to-coding-system charset
nil t))
(not (eq charset 'ascii)))
- (mm-decode-coding-string (buffer-string) charset)
- (mm-string-as-multibyte (buffer-string)))
+ (decode-coding-string (buffer-string) charset)
+ (string-as-multibyte (buffer-string)))
(erase-buffer)
(mm-enable-multibyte)))
(goto-char (point-min))
,(point-max-marker))))))))
(defvar shr-map)
+(defvar shr-image-map)
(autoload 'widget-convert-button "wid-edit")
+ (defvar widget-keymap)
(defun mm-convert-shr-links ()
(let ((start (point-min))
- end)
+ end keymap)
(while (and start
(< start (point-max)))
(when (setq start (text-property-not-all start (point-max) 'shr-url nil))
(widget-convert-button
'url-link start end
:help-echo (get-text-property start 'help-echo)
- ;;; FIXME Should only use the image map on images.
- :keymap shr-image-map
+ :keymap (setq keymap (copy-keymap shr-map))
(get-text-property start 'shr-url))
- (put-text-property start end 'local-map nil)
+ ;; Remove keymap that `shr-urlify' adds.
+ (put-text-property start end 'keymap nil)
+ ;; Mask keys that launch `widget-button-click'.
+ ;; Those bindings are provided by `widget-keymap'
+ ;; that is a parent of `gnus-article-mode-map'.
+ (dolist (key (where-is-internal #'widget-button-click widget-keymap))
+ (unless (lookup-key keymap key)
+ (define-key keymap key #'ignore)))
(dolist (overlay (overlays-at start))
(overlay-put overlay 'face nil))
(setq start end)))))
-;;; url-http.el --- HTTP retrieval routines
+;;; url-http.el --- HTTP retrieval routines -*- lexical-binding:t -*-
;; Copyright (C) 1999, 2001, 2004-2016 Free Software Foundation, Inc.
;;; Code:
(require 'cl-lib)
+(require 'puny)
+(require 'nsm)
(eval-when-compile
(require 'subr-x))
(507 insufficient-storage "Insufficient storage"))
"The HTTP return codes and their text.")
+(defconst url-https-default-port 443 "Default HTTPS port.")
+
;(eval-when-compile
;; These are all macros so that they are hidden from external sight
;; when the file is byte-compiled.
;; `url-open-stream' needs a buffer in which to do things
;; like authentication. But we use another buffer afterwards.
(unwind-protect
- (let ((proc (url-open-stream host buf host port gateway-method)))
+ (let ((proc (url-open-stream host buf
+ (if url-using-proxy
+ (url-host url-using-proxy)
+ host)
+ (if url-using-proxy
+ (url-port url-using-proxy)
+ port)
+ gateway-method)))
;; url-open-stream might return nil.
(when (processp proc)
;; Drop the temp buffer link before killing the buffer.
(if connection
(url-http-mark-connection-as-busy host port connection))))
+(defun url-http--user-agent-default-string ()
+ "Compute a default User-Agent string based on `url-privacy-level'."
+ (let ((package-info (when url-package-name
+ (format "%s/%s" url-package-name url-package-version)))
+ (emacs-info (unless (and (listp url-privacy-level)
+ (memq 'emacs url-privacy-level))
+ (format "Emacs/%s" emacs-version)))
+ (os-info (unless (and (listp url-privacy-level)
+ (memq 'os url-privacy-level))
+ (format "(%s; %s)" url-system-type url-os-type)))
+ (url-info (format "URL/%s" url-version)))
+ (string-join (delq nil (list package-info url-info
+ emacs-info os-info))
+ " ")))
+
;; Building an HTTP request
(defun url-http-user-agent-string ()
- (if (or (eq url-privacy-level 'paranoid)
- (and (listp url-privacy-level)
- (memq 'agent url-privacy-level)))
- ""
- (if (functionp url-user-agent)
- (funcall url-user-agent)
- url-user-agent)))
+ "Compute a User-Agent string.
+The string is based on `url-privacy-level' and `url-user-agent'."
+ (let* ((hide-ua
+ (or (eq url-privacy-level 'paranoid)
+ (and (listp url-privacy-level)
+ (memq 'agent url-privacy-level))))
+ (ua-string
+ (and (not hide-ua)
+ (cond
+ ((functionp url-user-agent) (funcall url-user-agent))
+ ((stringp url-user-agent) url-user-agent)
+ ((eq url-user-agent 'default) (url-http--user-agent-default-string))))))
+ (if ua-string (format "User-Agent: %s\r\n" (string-trim ua-string)) "")))
(defun url-http-create-request (&optional ref-url)
"Create an HTTP request for `url-http-target-url', referred to by REF-URL."
;; allows us to elide null lines directly, at the cost of making
;; the layout less clear.
(setq request
- ;; We used to concat directly, but if one of the strings happens
- ;; to being multibyte (even if it only contains pure ASCII) then
- ;; every string gets converted with `string-MAKE-multibyte' which
- ;; turns the 127-255 codes into things like latin-1 accented chars
- ;; (it would work right if it used `string-TO-multibyte' instead).
- ;; So to avoid the problem we force every string to be unibyte.
- (mapconcat
- ;; FIXME: Instead of `string-AS-unibyte' we'd want
- ;; `string-to-unibyte', so as to properly signal an error if one
- ;; of the strings contains a multibyte char.
- 'string-as-unibyte
- (delq nil
- (list
+ (concat
;; The request
(or url-http-method "GET") " "
(if using-proxy (url-recreate-url url-http-target-url) real-fname)
(url-scheme-get-property
(url-type url-http-target-url) 'default-port))
(format
- "Host: %s:%d\r\n" host (url-port url-http-target-url))
- (format "Host: %s\r\n" host))
+ "Host: %s:%d\r\n" (puny-encode-domain host)
+ (url-port url-http-target-url))
+ (format "Host: %s\r\n" (puny-encode-domain host)))
;; Who its from
(if url-personal-mail-address
(concat
"\r\n"
;; Any data
url-http-data))
- ""))
+ ;; Bug#23750
+ (unless (= (string-bytes request)
+ (length request))
+ (error "Multibyte text in HTTP request: %s" request))
(url-http-debug "Request is: \n%s" request)
request))
)
(declare-function gnutls-peer-status "gnutls.c" (proc))
+(declare-function gnutls-negotiate "gnutls.el" t t)
(defun url-http-parse-headers ()
"Parse and handle HTTP specific headers.
;; We do not support agent-driven negotiation, so we just
;; redirect to the preferred URI if one is provided.
nil)
- ((or `moved-permanently `found `temporary-redirect) ; 301 302 307
- ;; If the 301|302 status code is received in response to a
- ;; request other than GET or HEAD, the user agent MUST NOT
- ;; automatically redirect the request unless it can be
- ;; confirmed by the user, since this might change the
- ;; conditions under which the request was issued.
- (unless (member url-http-method '("HEAD" "GET"))
- (setq redirect-uri nil)))
- (`see-other ; 303
+ (`see-other ; 303
;; The response to the request can be found under a different
;; URI and SHOULD be retrieved using a GET method on that
;; resource.
;; )
;; These unfortunately cannot be macros... please ignore them!
-(defun url-http-idle-sentinel (proc why)
+(defun url-http-idle-sentinel (proc _why)
"Remove (now defunct) process PROC from the list of open connections."
(maphash (lambda (key val)
(if (memq proc val)
(erase-buffer)
(let ((url-request-method url-http-method)
(url-request-extra-headers url-http-extra-headers)
- (url-request-data url-http-data))
+ (url-request-data url-http-data)
+ (url-using-proxy (url-find-proxy-for-url
+ url-current-object
+ (url-host url-current-object))))
+ (when url-using-proxy
+ (setq url-using-proxy
+ (url-generic-parse-url url-using-proxy)))
(url-http url-current-object url-callback-function
url-callback-arguments (current-buffer)))))
((url-http-parse-headers)
(url-http-activate-callback))))))
-(defun url-http-simple-after-change-function (st nd length)
+(defun url-http-simple-after-change-function (_st _nd _length)
;; Function used when we do NOT know how long the document is going to be
;; Just _very_ simple 'downloaded %d' type of info.
- (url-lazy-message "Reading %s..." (file-size-human-readable nd)))
+ (url-lazy-message "Reading %s..." (file-size-human-readable (buffer-size))))
-(defun url-http-content-length-after-change-function (st nd length)
+(defun url-http-content-length-after-change-function (_st nd _length)
"Function used when we DO know how long the document is going to be.
More sophisticated percentage downloaded, etc.
Also does minimal parsing of HTTP headers and will actually cause
(if (url-http-parse-headers)
(url-http-activate-callback))))))))))
-(defun url-http-wait-for-headers-change-function (st nd length)
+(defun url-http-wait-for-headers-change-function (_st nd _length)
;; This will wait for the headers to arrive and then splice in the
;; next appropriate after-change-function, etc.
(url-http-debug "url-http-wait-for-headers-change-function (%s)"
(let ((end-of-headers nil)
(old-http nil)
(process-buffer (current-buffer))
- (content-length nil))
+ ;; (content-length nil)
+ )
(when (not (bobp))
(goto-char (point-min))
(if (and (looking-at ".*\n") ; have one line at least
"Retrieve URL via HTTP asynchronously.
URL must be a parsed URL. See `url-generic-parse-url' for details.
-When retrieval is completed, execute the function CALLBACK, passing it
-an updated value of CBARGS as arguments. The first element in CBARGS
-should be a plist describing what has happened so far during the
-request, as described in the docstring of `url-retrieve' (if in
-doubt, specify nil).
+When retrieval is completed, execute the function CALLBACK,
+passing it an updated value of CBARGS as arguments. The first
+element in CBARGS should be a plist describing what has happened
+so far during the request, as described in the docstring of
+`url-retrieve' (if in doubt, specify nil). The current buffer
+then CALLBACK is executed is the retrieval buffer.
Optional arg RETRY-BUFFER, if non-nil, specifies the buffer of a
previous `url-http' call, which is being re-attempted.
Optional arg GATEWAY-METHOD specifies the gateway to be used,
-overriding the value of `url-gateway-method'."
+overriding the value of `url-gateway-method'.
+
+The return value of this function is the retrieval buffer."
(cl-check-type url vector "Need a pre-parsed URL.")
- (let* ((host (url-host (or url-using-proxy url)))
- (port (url-port (or url-using-proxy url)))
+ (let* (;; (host (url-host (or url-using-proxy url)))
+ ;; (port (url-port (or url-using-proxy url)))
(nsm-noninteractive (or url-request-noninteractive
(and (boundp 'url-http-noninteractive)
url-http-noninteractive)))
- (connection (url-http-find-free-connection host port gateway-method))
+ (connection (url-http-find-free-connection (url-host url)
+ (url-port url)
+ gateway-method))
(mime-accept-string url-mime-accept-string)
(buffer (or retry-buffer
(generate-new-buffer
- (format " *http %s:%d*" host port)))))
+ (format " *http %s:%d*" (url-host url) (url-port url))))))
(if (not connection)
;; Failed to open the connection for some reason
(progn
(kill-buffer buffer)
(setq buffer nil)
- (error "Could not create connection to %s:%d" host port))
+ (error "Could not create connection to %s:%d" (url-host url)
+ (url-port url)))
(with-current-buffer buffer
(mm-disable-multibyte)
(setq url-current-object url
(set-process-sentinel connection 'url-http-async-sentinel))
(`failed
;; Asynchronous connection failed
- (error "Could not create connection to %s:%d" host port))
+ (error "Could not create connection to %s:%d" (url-host url)
+ (url-port url)))
(_
- (set-process-sentinel connection
- 'url-http-end-of-document-sentinel)
- (process-send-string connection (url-http-create-request))))))
+ (if (and url-http-proxy (string= "https"
+ (url-type url-current-object)))
+ (url-https-proxy-connect connection)
+ (set-process-sentinel connection
+ 'url-http-end-of-document-sentinel)
+ (process-send-string connection (url-http-create-request)))))))
buffer))
+(defun url-https-proxy-connect (connection)
+ (setq url-http-after-change-function 'url-https-proxy-after-change-function)
+ (process-send-string connection (format (concat "CONNECT %s:%d HTTP/1.1\r\n"
+ "Host: %s\r\n"
+ "\r\n")
+ (url-host url-current-object)
+ (or (url-port url-current-object)
+ url-https-default-port)
+ (url-host url-current-object))))
+
+(defun url-https-proxy-after-change-function (_st _nd _length)
+ (let* ((process-buffer (current-buffer))
+ (proc (get-buffer-process process-buffer)))
+ (goto-char (point-min))
+ (when (re-search-forward "^\r?\n" nil t)
+ (backward-char 1)
+ ;; Saw the end of the headers
+ (setq url-http-end-of-headers (set-marker (make-marker) (point)))
+ (url-http-parse-response)
+ (cond
+ ((null url-http-response-status)
+ ;; We got back a headerless malformed response from the
+ ;; server.
+ (url-http-activate-callback)
+ (error "Malformed response from proxy, fail!"))
+ ((= url-http-response-status 200)
+ (if (gnutls-available-p)
+ (condition-case e
+ (let ((tls-connection (gnutls-negotiate
+ :process proc
+ :hostname (url-host url-current-object)
+ :verify-error nil)))
+ ;; check certificate validity
+ (setq tls-connection
+ (nsm-verify-connection tls-connection
+ (url-host url-current-object)
+ (url-port url-current-object)))
+ (with-current-buffer process-buffer (erase-buffer))
+ (set-process-buffer tls-connection process-buffer)
+ (setq url-http-after-change-function
+ 'url-http-wait-for-headers-change-function)
+ (set-process-filter tls-connection 'url-http-generic-filter)
+ (process-send-string tls-connection
+ (url-http-create-request)))
+ (gnutls-error
+ (url-http-activate-callback)
+ (error "gnutls-error: %s" e))
+ (error
+ (url-http-activate-callback)
+ (error "error: %s" e)))
+ (error "error: gnutls support needed!")))
+ (t
+ (message "error response: %d" url-http-response-status)
+ (url-http-activate-callback))))))
+
(defun url-http-async-sentinel (proc why)
;; We are performing an asynchronous connection, and a status change
;; has occurred.
(url-http-end-of-document-sentinel proc why))
((string= (substring why 0 4) "open")
(setq url-http-connection-opened t)
- (condition-case error
- (process-send-string proc (url-http-create-request))
- (file-error
- (setq url-http-connection-opened nil)
- (message "HTTP error: %s" error))))
+ (if (and url-http-proxy (string= "https" (url-type url-current-object)))
+ (url-https-proxy-connect proc)
+ (condition-case error
+ (process-send-string proc (url-http-create-request))
+ (file-error
+ (setq url-http-connection-opened nil)
+ (message "HTTP error: %s" error)))))
(t
(setf (car url-callback-arguments)
(nconc (list :error (list 'error 'connection-failed why
(defalias 'url-http-file-readable-p 'url-http-file-exists-p)
-(defun url-http-head-file-attributes (url &optional id-format)
+(defun url-http-head-file-attributes (url &optional _id-format)
(let ((buffer (url-http-head url)))
(when buffer
(prog1
nil nil nil) ;whether gid would change ; inode ; device.
(kill-buffer buffer)))))
-(declare-function url-dav-file-attributes "url-dav" (url &optional id-format))
+(declare-function url-dav-file-attributes "url-dav" (url &optional _id-format))
(defun url-http-file-attributes (url &optional id-format)
(if (url-dav-supported-p url)
;; with url-http.el on systems with 8-character file names.
(require 'tls)
-(defconst url-https-default-port 443 "Default HTTPS port.")
(defconst url-https-asynchronous-p t "HTTPS retrievals are asynchronous.")
;; FIXME what is the point of this alias being an autoload?
(goto-char (point-min))
(unless (eobp)
;; Indent the expanded log entry.
- (indent-region (point-min) (point-max) 2)
+ (while (re-search-forward "^ " nil t)
+ (replace-match "")
+ (forward-line))
(buffer-string))))
(defun vc-git-region-history (file buffer lfrom lto)
(cons 'vc-git-region-history-font-lock-keywords
(cdr font-lock-defaults))))
+(defun vc-git--asciify-coding-system ()
+ ;; Try to reconcile the content encoding with the encoding of Git's
+ ;; auxiliary output (which is ASCII or ASCII-compatible), bug#23595.
+ (unless (let ((samp "Binary files differ"))
+ (string-equal samp (decode-coding-string
+ samp coding-system-for-read t)))
+ (setq coding-system-for-read 'undecided)))
(autoload 'vc-switches "vc")
"Get a difference report using Git between two revisions of FILES."
(let (process-file-side-effects
(command "diff-tree"))
+ (vc-git--asciify-coding-system)
(if rev2
;; Diffing against the empty tree.
(unless rev1 (setq rev1 "4b825dc642cb6eb9a060e54bf8d69288fbee4904"))
table))
(defun vc-git-annotate-command (file buf &optional rev)
+ (vc-git--asciify-coding-system)
(let ((name (file-relative-name file)))
(apply #'vc-git-command buf 'async nil "blame" "--date=short"
(append (vc-switches 'git 'annotate)
(let ((coding-system-for-read
(or coding-system-for-read vc-git-log-output-coding-system))
(coding-system-for-write
- (or coding-system-for-write vc-git-commits-coding-system)))
+ (or coding-system-for-write vc-git-commits-coding-system))
+ (process-environment (cons "GIT_DIR" process-environment)))
(apply 'vc-do-command (or buffer "*vc*") okstatus vc-git-program
;; http://debbugs.gnu.org/16897
(unless (and (not (cdr-safe file-or-list))
(coding-system-for-write
(or coding-system-for-write vc-git-commits-coding-system))
(process-environment (cons "PAGER=" process-environment)))
+ (push "GIT_DIR" process-environment)
(apply 'process-file vc-git-program nil buffer nil command args)))
(defun vc-git--out-ok (command &rest args)
{
/* Since CRLF is converted to LF within `decode_coding', we
can always open a file with binary mode. */
- callproc_fd[CALLPROC_PIPEREAD] = emacs_open (tempfile,
- O_RDONLY | O_BINARY, 0);
+ callproc_fd[CALLPROC_PIPEREAD] = emacs_open (tempfile, O_RDONLY, 0);
if (callproc_fd[CALLPROC_PIPEREAD] < 0)
{
int open_errno = errno;
return unbind_to (count, val);
}
\f
-#ifndef WINDOWSNT
-static int relocate_fd (int fd, int minfd);
-#endif
-
static char **
add_env (char **env, char **new_env, char *string)
{
char *p = *ep, *q = string;
while (ok)
{
- if (*q != *p)
+ if (*p && *q != *p)
break;
if (*q == 0)
/* The string is a lone variable name; keep it for now, we
#ifdef WINDOWSNT
prepare_standard_handles (in, out, err, handles);
- set_process_dir (SDATA (current_dir));
+ set_process_dir (SSDATA (current_dir));
/* Spawn the child. (See w32proc.c:sys_spawnve). */
cpid = spawnve (_P_NOWAIT, new_argv[0], new_argv, env);
reset_standard_handles (in, out, err, handles);
return cpid;
#else /* not WINDOWSNT */
- /* Make sure that in, out, and err are not actually already in
- descriptors zero, one, or two; this could happen if Emacs is
- started with its standard in, out, or error closed, as might
- happen under X. */
- {
- int oin = in, oout = out;
-
- /* We have to avoid relocating the same descriptor twice! */
-
- in = relocate_fd (in, 3);
-
- if (out == oin)
- out = in;
- else
- out = relocate_fd (out, 3);
-
- if (err == oin)
- err = in;
- else if (err == oout)
- err = out;
- else
- err = relocate_fd (err, 3);
- }
#ifndef MSDOS
/* Redirect file descriptors and clear the close-on-exec flag on the
redirected ones. IN, OUT, and ERR are close-on-exec so they
need not be closed explicitly. */
- dup2 (in, 0);
- dup2 (out, 1);
- dup2 (err, 2);
+ dup2 (in, STDIN_FILENO);
+ dup2 (out, STDOUT_FILENO);
+ dup2 (err, STDERR_FILENO);
setpgid (0, 0);
tcsetpgrp (0, pid);
#endif /* not WINDOWSNT */
}
-#ifndef WINDOWSNT
-/* Move the file descriptor FD so that its number is not less than MINFD.
- If the file descriptor is moved at all, the original is closed on MSDOS,
- but not elsewhere as the caller will close it anyway. */
-static int
-relocate_fd (int fd, int minfd)
-{
- if (fd >= minfd)
- return fd;
- else
- {
- int new = fcntl (fd, F_DUPFD_CLOEXEC, minfd);
- if (new == -1)
- {
- emacs_perror ("while setting up child");
- _exit (EXIT_CANCELED);
- }
-#ifdef MSDOS
- emacs_close (fd);
-#endif
- return new;
- }
-}
-#endif /* not WINDOWSNT */
-
static bool
getenv_internal_1 (const char *var, ptrdiff_t varlen, char **value,
ptrdiff_t *valuelen, Lisp_Object env)
&& SBYTES (entry) >= varlen
#ifdef WINDOWSNT
/* NT environment variables are case insensitive. */
- && ! strnicmp (SDATA (entry), var, varlen)
+ && ! strnicmp (SSDATA (entry), var, varlen)
#else /* not WINDOWSNT */
&& ! memcmp (SDATA (entry), var, varlen)
#endif /* not WINDOWSNT */
#include <config.h>
#include <unistd.h>
+#include <filevercmp.h>
#include <intprops.h>
#include <vla.h>
+#include <errno.h>
#include "lisp.h"
#include "character.h"
The strings are compared by the numeric values of their characters.
For instance, STR1 is "less than" STR2 if its first differing
character has a smaller numeric value. If IGNORE-CASE is non-nil,
- characters are converted to lower-case before comparing them. Unibyte
+ characters are converted to upper-case before comparing them. Unibyte
strings are converted to multibyte for comparison.
The value is t if the strings (or specified portions) match.
return i1 < SCHARS (string2) ? Qt : Qnil;
}
+DEFUN ("string-version-lessp", Fstring_version_lessp,
+ Sstring_version_lessp, 2, 2, 0,
+ doc: /* Return non-nil if S1 is less than S2, as version strings.
+
+This function compares version strings S1 and S2:
+ 1) By prefix lexicographically.
+ 2) Then by version (similarly to version comparison of Debian's dpkg).
+ Leading zeros in version numbers are ignored.
+ 3) If both prefix and version are equal, compare as ordinary strings.
+
+For example, \"foo2.png\" compares less than \"foo12.png\".
+Case is significant.
+Symbols are also allowed; their print names are used instead. */)
+ (Lisp_Object string1, Lisp_Object string2)
+{
+ if (SYMBOLP (string1))
+ string1 = SYMBOL_NAME (string1);
+ if (SYMBOLP (string2))
+ string2 = SYMBOL_NAME (string2);
+ CHECK_STRING (string1);
+ CHECK_STRING (string2);
+
+ char *p1 = SSDATA (string1);
+ char *p2 = SSDATA (string2);
+ char *lim1 = p1 + SBYTES (string1);
+ char *lim2 = p2 + SBYTES (string2);
+ int cmp;
+
+ while ((cmp = filevercmp (p1, p2)) == 0)
+ {
+ /* If the strings are identical through their first null bytes,
+ skip past identical prefixes and try again. */
+ ptrdiff_t size = strlen (p1) + 1;
+ p1 += size;
+ p2 += size;
+ if (lim1 < p1)
+ return lim2 < p2 ? Qnil : Qt;
+ if (lim2 < p2)
+ return Qnil;
+ }
+
+ return cmp < 0 ? Qt : Qnil;
+}
+
DEFUN ("string-collate-lessp", Fstring_collate_lessp, Sstring_collate_lessp, 2, 4, 0,
doc: /* Return t if first arg string is less than second in collation order.
Symbols are also allowed; their print names are used instead.
(register Lisp_Object elt, Lisp_Object list)
{
register Lisp_Object tail;
- for (tail = list; CONSP (tail); tail = XCDR (tail))
+ for (tail = list; !NILP (tail); tail = XCDR (tail))
{
register Lisp_Object tem;
CHECK_LIST_CONS (tail, list);
if (!FLOATP (elt))
return Fmemq (elt, list);
- for (tail = list; CONSP (tail); tail = XCDR (tail))
+ for (tail = list; !NILP (tail); tail = XCDR (tail))
{
register Lisp_Object tem;
CHECK_LIST_CONS (tail, list);
{
Lisp_Object tail, prev;
- for (tail = seq, prev = Qnil; CONSP (tail); tail = XCDR (tail))
+ for (tail = seq, prev = Qnil; !NILP (tail); tail = XCDR (tail))
{
CHECK_LIST_CONS (tail, seq);
{
char *str = NULL;
#ifdef HAVE_LANGINFO_CODESET
- Lisp_Object val;
if (EQ (item, Qcodeset))
{
str = nl_langinfo (CODESET);
for (i = 0; i < 7; i++)
{
str = nl_langinfo (days[i]);
- val = build_unibyte_string (str);
+ AUTO_STRING (val, str);
/* Fixme: Is this coding system necessarily right, even if
it is consistent with CODESET? If not, what to do? */
ASET (v, i, code_convert_string_norecord (val, Vlocale_coding_system,
for (i = 0; i < 12; i++)
{
str = nl_langinfo (months[i]);
- val = build_unibyte_string (str);
+ AUTO_STRING (val, str);
ASET (v, i, code_convert_string_norecord (val, Vlocale_coding_system,
0));
}
Low-level Functions
***********************************************************************/
-struct hash_table_test hashtest_eq, hashtest_eql, hashtest_equal;
-
/* Compare KEY1 which has hash code HASH1 and KEY2 with hash code
HASH2 in hash table H using `eql'. Value is true if KEY1 and
KEY2 are the same. */
return !NILP (call2 (ht->user_cmp_function, key1, key2));
}
-
/* Value is a hash code for KEY for use in hash table H which uses
`eq' to compare keys. The hash code returned is guaranteed to fit
in a Lisp integer. */
static EMACS_UINT
hashfn_eq (struct hash_table_test *ht, Lisp_Object key)
{
- EMACS_UINT hash = XHASH (key) ^ XTYPE (key);
- return hash;
+ return XHASH (key) ^ XTYPE (key);
}
/* Value is a hash code for KEY for use in hash table H which uses
- `eql' to compare keys. The hash code returned is guaranteed to fit
+ `equal' to compare keys. The hash code returned is guaranteed to fit
in a Lisp integer. */
static EMACS_UINT
-hashfn_eql (struct hash_table_test *ht, Lisp_Object key)
+hashfn_equal (struct hash_table_test *ht, Lisp_Object key)
{
- EMACS_UINT hash;
- if (FLOATP (key))
- hash = sxhash (key, 0);
- else
- hash = XHASH (key) ^ XTYPE (key);
- return hash;
+ return sxhash (key, 0);
}
/* Value is a hash code for KEY for use in hash table H which uses
- `equal' to compare keys. The hash code returned is guaranteed to fit
+ `eql' to compare keys. The hash code returned is guaranteed to fit
in a Lisp integer. */
static EMACS_UINT
-hashfn_equal (struct hash_table_test *ht, Lisp_Object key)
+hashfn_eql (struct hash_table_test *ht, Lisp_Object key)
{
- EMACS_UINT hash = sxhash (key, 0);
- return hash;
+ return FLOATP (key) ? hashfn_equal (ht, key) : hashfn_eq (ht, key);
}
/* Value is a hash code for KEY for use in hash table H which uses as
return hashfn_eq (ht, hash);
}
+struct hash_table_test const
+ hashtest_eq = { LISPSYM_INITIALLY (Qeq), LISPSYM_INITIALLY (Qnil),
+ LISPSYM_INITIALLY (Qnil), 0, hashfn_eq },
+ hashtest_eql = { LISPSYM_INITIALLY (Qeql), LISPSYM_INITIALLY (Qnil),
+ LISPSYM_INITIALLY (Qnil), cmpfn_eql, hashfn_eql },
+ hashtest_equal = { LISPSYM_INITIALLY (Qequal), LISPSYM_INITIALLY (Qnil),
+ LISPSYM_INITIALLY (Qnil), cmpfn_equal, hashfn_equal };
+
/* Allocate basically initialized hash table. */
static struct Lisp_Hash_Table *
Lisp Interface
***********************************************************************/
+DEFUN ("sxhash-eq", Fsxhash_eq, Ssxhash_eq, 1, 1, 0,
+ doc: /* Return an integer hash code for OBJ suitable for `eq'.
+If (eq A B), then (= (sxhash-eq A) (sxhash-eq B)). */)
+ (Lisp_Object obj)
+{
+ return make_number (hashfn_eq (NULL, obj));
+}
-DEFUN ("sxhash", Fsxhash, Ssxhash, 1, 1, 0,
- doc: /* Compute a hash code for OBJ and return it as integer. */)
+DEFUN ("sxhash-eql", Fsxhash_eql, Ssxhash_eql, 1, 1, 0,
+ doc: /* Return an integer hash code for OBJ suitable for `eql'.
+If (eql A B), then (= (sxhash-eql A) (sxhash-eql B)). */)
(Lisp_Object obj)
{
- EMACS_UINT hash = sxhash (obj, 0);
- return make_number (hash);
+ return make_number (hashfn_eql (NULL, obj));
}
+DEFUN ("sxhash-equal", Fsxhash_equal, Ssxhash_equal, 1, 1, 0,
+ doc: /* Return an integer hash code for OBJ suitable for `equal'.
+If (equal A B), then (= (sxhash-equal A) (sxhash-equal B)). */)
+ (Lisp_Object obj)
+{
+ return make_number (hashfn_equal (NULL, obj));
+}
DEFUN ("make-hash-table", Fmake_hash_table, Smake_hash_table, 0, MANY, 0,
doc: /* Create and return a new hash table.
#include "sha256.h"
#include "sha512.h"
+static Lisp_Object
+make_digest_string (Lisp_Object digest, int digest_size)
+{
+ unsigned char *p = SDATA (digest);
+
+ for (int i = digest_size - 1; i >= 0; i--)
+ {
+ static char const hexdigit[16] = "0123456789abcdef";
+ int p_i = p[i];
+ p[2 * i] = hexdigit[p_i >> 4];
+ p[2 * i + 1] = hexdigit[p_i & 0xf];
+ }
+ return digest;
+}
+
/* ALGORITHM is a symbol: md5, sha1, sha224 and so on. */
static Lisp_Object
Lisp_Object end, Lisp_Object coding_system, Lisp_Object noerror,
Lisp_Object binary)
{
- int i;
ptrdiff_t size, start_char = 0, start_byte, end_char = 0, end_byte;
register EMACS_INT b, e;
register struct buffer *bp;
SSDATA (digest));
if (NILP (binary))
- {
- unsigned char *p = SDATA (digest);
- for (i = digest_size - 1; i >= 0; i--)
- {
- static char const hexdigit[16] = "0123456789abcdef";
- int p_i = p[i];
- p[2 * i] = hexdigit[p_i >> 4];
- p[2 * i + 1] = hexdigit[p_i & 0xf];
- }
- return digest;
- }
+ return make_digest_string (digest, digest_size);
else
return make_unibyte_string (SSDATA (digest), digest_size);
}
{
return secure_hash (algorithm, object, start, end, Qnil, Qnil, binary);
}
+
+DEFUN ("buffer-hash", Fbuffer_hash, Sbuffer_hash, 0, 1, 0,
+ doc: /* Return a hash of the contents of BUFFER-OR-NAME.
+This hash is performed on the raw internal format of the buffer,
+disregarding any coding systems.
+If nil, use the current buffer." */ )
+ (Lisp_Object buffer_or_name)
+{
+ Lisp_Object buffer;
+ struct buffer *b;
+ struct sha1_ctx ctx;
+
+ if (NILP (buffer_or_name))
+ buffer = Fcurrent_buffer ();
+ else
+ buffer = Fget_buffer (buffer_or_name);
+ if (NILP (buffer))
+ nsberror (buffer_or_name);
+
+ b = XBUFFER (buffer);
+ sha1_init_ctx (&ctx);
+
+ /* Process the first part of the buffer. */
+ sha1_process_bytes (BUF_BEG_ADDR (b),
+ BUF_GPT_BYTE (b) - BUF_BEG_BYTE (b),
+ &ctx);
+
+ /* If the gap is before the end of the buffer, process the last half
+ of the buffer. */
+ if (BUF_GPT_BYTE (b) < BUF_Z_BYTE (b))
+ sha1_process_bytes (BUF_GAP_END_ADDR (b),
+ BUF_Z_ADDR (b) - BUF_GAP_END_ADDR (b),
+ &ctx);
+
+ Lisp_Object digest = make_uninit_string (SHA1_DIGEST_SIZE * 2);
+ sha1_finish_ctx (&ctx, SSDATA (digest));
+ return make_digest_string (digest, SHA1_DIGEST_SIZE);
+}
+
\f
void
syms_of_fns (void)
DEFSYM (Qkey_or_value, "key-or-value");
DEFSYM (Qkey_and_value, "key-and-value");
- defsubr (&Ssxhash);
+ defsubr (&Ssxhash_eq);
+ defsubr (&Ssxhash_eql);
+ defsubr (&Ssxhash_equal);
defsubr (&Smake_hash_table);
defsubr (&Scopy_hash_table);
defsubr (&Shash_table_count);
defsubr (&Sstring_equal);
defsubr (&Scompare_strings);
defsubr (&Sstring_lessp);
+ defsubr (&Sstring_version_lessp);
defsubr (&Sstring_collate_lessp);
defsubr (&Sstring_collate_equalp);
defsubr (&Sappend);
defsubr (&Sbase64_decode_string);
defsubr (&Smd5);
defsubr (&Ssecure_hash);
+ defsubr (&Sbuffer_hash);
defsubr (&Slocale_info);
-
- hashtest_eq.name = Qeq;
- hashtest_eq.user_hash_function = Qnil;
- hashtest_eq.user_cmp_function = Qnil;
- hashtest_eq.cmpfn = 0;
- hashtest_eq.hashfn = hashfn_eq;
-
- hashtest_eql.name = Qeql;
- hashtest_eql.user_hash_function = Qnil;
- hashtest_eql.user_cmp_function = Qnil;
- hashtest_eql.cmpfn = cmpfn_eql;
- hashtest_eql.hashfn = hashfn_eql;
-
- hashtest_equal.name = Qequal;
- hashtest_equal.user_hash_function = Qnil;
- hashtest_equal.user_cmp_function = Qnil;
- hashtest_equal.cmpfn = cmpfn_equal;
- hashtest_equal.hashfn = hashfn_equal;
}
int c;
unsigned char hide_char = 0;
struct emacs_tty etty;
- bool etty_valid;
+ bool etty_valid UNINIT;
/* Check, whether we need to suppress echoing. */
if (CHARACTERP (Vread_hide_char))
/* Manipulate tty. */
if (hide_char)
{
- etty_valid = emacs_get_tty (fileno (stdin), &etty) == 0;
+ etty_valid = emacs_get_tty (STDIN_FILENO, &etty) == 0;
if (etty_valid)
- set_binary_mode (fileno (stdin), O_BINARY);
- suppress_echo_on_tty (fileno (stdin));
+ set_binary_mode (STDIN_FILENO, O_BINARY);
+ suppress_echo_on_tty (STDIN_FILENO);
}
fwrite (SDATA (prompt), 1, SBYTES (prompt), stdout);
fprintf (stdout, "\n");
if (etty_valid)
{
- emacs_set_tty (fileno (stdin), &etty, 0);
- set_binary_mode (fileno (stdin), O_TEXT);
+ emacs_set_tty (STDIN_FILENO, &etty, 0);
+ set_binary_mode (STDIN_FILENO, O_TEXT);
}
}
Qrear_nonsticky, Qt, Qnil);
Fput_text_property (make_number (BEG), make_number (PT),
Qfield, Qt, Qnil);
- Fadd_text_properties (make_number (BEG), make_number (PT),
- Vminibuffer_prompt_properties, Qnil);
+ if (CONSP (Vminibuffer_prompt_properties))
+ {
+ /* We want to apply all properties from
+ `minibuffer-prompt-properties' to the region normally,
+ but if the `face' property is present, add that
+ property to the end of the face properties to avoid
+ overwriting faces. */
+ Lisp_Object list = Vminibuffer_prompt_properties;
+ while (CONSP (list))
+ {
+ Lisp_Object key = XCAR (list);
+ list = XCDR (list);
+ if (CONSP (list))
+ {
+ Lisp_Object val = XCAR (list);
+ list = XCDR (list);
+ if (EQ (key, Qface))
+ Fadd_face_text_property (make_number (BEG),
+ make_number (PT), val, Qt, Qnil);
+ else
+ Fput_text_property (make_number (BEG), make_number (PT),
+ key, val, Qnil);
+ }
+ }
+ }
}
unbind_to (count1, Qnil);
}
}
/* Return a buffer to be used as the minibuffer at depth `depth'.
- depth = 0 is the lowest allowed argument, and that is the value
- used for nonrecursive minibuffer invocations. */
+ depth = 0 is the lowest allowed argument, and that is the value
+ used for nonrecursive minibuffer invocations. */
Lisp_Object
get_minibuffer (EMACS_INT depth)
{
- Lisp_Object tail, num, buf;
- char name[sizeof " *Minibuf-*" + INT_STRLEN_BOUND (EMACS_INT)];
-
- XSETFASTINT (num, depth);
- tail = Fnthcdr (num, Vminibuffer_list);
+ Lisp_Object tail = Fnthcdr (make_number (depth), Vminibuffer_list);
if (NILP (tail))
{
tail = list1 (Qnil);
Vminibuffer_list = nconc2 (Vminibuffer_list, tail);
}
- buf = Fcar (tail);
+ Lisp_Object buf = Fcar (tail);
if (NILP (buf) || !BUFFER_LIVE_P (XBUFFER (buf)))
{
- buf = Fget_buffer_create
- (make_formatted_string (name, " *Minibuf-%"pI"d*", depth));
+ static char const name_fmt[] = " *Minibuf-%"pI"d*";
+ char name[sizeof name_fmt + INT_STRLEN_BOUND (EMACS_INT)];
+ AUTO_STRING_WITH_LEN (lname, name, sprintf (name, name_fmt, depth));
+ buf = Fget_buffer_create (lname);
/* Although the buffer's name starts with a space, undo should be
enabled in it. */
This returns the first element of LIST whose car matches the string or
symbol KEY, or nil if no match exists. When performing the
comparison, symbols are first converted to strings, and unibyte
- strings to multibyte. If the optional arg CASE-FOLD is non-nil, case
- is ignored.
+ strings to multibyte. If the optional arg CASE-FOLD is non-nil, both
+ KEY and the elements of LIST are upcased for comparison.
Unlike `assoc', KEY can also match an entry in LIST consisting of a
single string, rather than a cons cell whose car is a string. */)
;; Select an expert-level for the same reason.
(viper-expert-level 5)
;; viper loads this even with -q so make sure it's empty!
- (viper-custom-file-name (make-temp-file "viper-tests"))
+ (viper-custom-file-name (make-temp-file "viper-tests" nil ".elc"))
(before-buffer (current-buffer)))
(unwind-protect
(progn