view lisp/eshell/em-glob.el @ 92870:8f17f65dd575

* textmodes/org.el (org-ctrl-c-star): Implement a missing branch in the decision tree. (org-select-remember-template): Cleaned the code. (org-prepare-dblock): Added the extra :content parameter. (org-write-agenda): New output type ".ics" files. (org-write-agenda): Call `org-icalendar-verify-function', both for time stamps and for TODO entries. (org-agenda-collect-markers, org-create-marker-find-array) (org-check-agenda-marker-table): New functions. (org-agenda-marker-table): New variable. (org-export-as-html): Revert the change that killed the html buffer. Side effects first need to be studied carefully. (org-get-tags-at): Fix the structure of the condition-case statement. (org-ts-regexp0, org-repeat-re, org-display-custom-time) (org-timestamp-change): Fix regulear expressions to swallow the extra character for repeat-shift control. (org-auto-repeat-maybe): Implement the new repeater mechanisms. (org-get-legal-level): Aliased to `org-get-valid-level'. (org-dblock-write:clocktable): Added a :link parameter, linking headlines to their location in the Org agenda files. (org-get-tags-at): Bugfix: prevent `org-back-to-heading' from throwing an error when getting tags before headlines. (org-timestamp-change, org-modify-ts-extra) (org-ts-regexp1): Fix timestamp editing. (org-agenda-custom-commands-local-options): New constant. (org-agenda-custom-commands): Use `org-agenda-custom-commands-local-options' to improve customize type. "htmlize": Removed hack to fix face problem with htmlize, it no longer seem necessary. (org-follow-link-hook): New hook. (org-agenda-custom-commands): Added "Component" as a tag for each item in a command serie. (org-open-at-point): Run `org-follow-link-hook'. (org-agenda-schedule): Bugfix: don't display marker type when it is `nil'. (org-store-link): org-irc required. (org-set-regexps-and-options): Parse the new logging options. (org-extract-log-state-settings): New function. (org-todo): Handle the new ways of recording state change stuff. (org-local-logging): New function. (org-columns-open-link): Fixed bug with opening link in column view. (org-local-logging): New function (org-todo): Make sure that LOGGING properties are honoured. (org-todo-keywords): Improve docstring. (org-startup-options): Cleanup startup options. (org-set-regexps-and-options): Process the "!" markers. (org-todo): Respect the new logging stuff. (org-log-note-how): New variable. (org-add-log-maybe): New parameter HOW that defines how logging should be done and also overrides PURPOSE. Add a docstring. (org-add-log-note): Check if we really need to ask for a note. (org-get-current-options): Digest the new keyword. (org-agenda-reset-markers): Renamed from `org-agenda-maybe-reset-markers'. FORCE argument removed. (org-diary, org-agenda-quit, org-prepare-agenda): Call the renamed function, without force argument. (org-buffer-property-keys): Bind local variables s and p. (org-make-tags-matcher): Allow "" to match an empty or non-existent property value. (org-export-as-html): Join unsorted lists when they directly follow each other. Such lists may be created by headlines that are converted to lists. (org-nofm-to-completion): New function. (org-export-as-html): Use :html-extension instead of org-export-html-extension. (org-store-link): Support for links from `rmail-summary-mode'. (org-columns-new, org-complete, org-set-property): Set the `include-columns' argument in the call to `org-buffer-property-keys'. (org-buffer-property-keys): New argument `include-columns', to include properties expected by any of the COLUMS formats in the current buffer. (org-cleaned-string-for-export): Get rid of drawers first, so that they will be removed also in the text before the first headline. (org-clock-report): Show the clocktable when found. (org-refile): Fix positioning bug when `org-reverse-note-order' is nil. (org-version): With prefix argument, insert `org-version' at point. (org-agenda-goto): Recenter the window after finding the target location, to make sure the correct position will be displayed. (org-agenda-get-deadlines): Don't scale priority with the warning period. (org-insert-heading): Don't break line in the middle of the line. (org-agenda-get-deadlines): Allow `org-deadline-warning-days' to be 0. (org-update-checkbox-count): Revamped to deal with hierarchical beckboxes. This was a patch from Miguel A. Figueroa-Villanueva. (org-remove-timestamp-with-keyword): New function. (org-schedule, org-deadline): Use `org-remove-timestamp-with-keyword' to make sure all such time stamps are removed. (org-mode): Support for `align'. (org-agenda-get-deadlines): Make sure priorities increase as the due date approaches and is passed. (org-remember-apply-template): Fixed problem with tags that contain "_" or "@". (org-make-link-regexps): Improve the regular expression for plain links. (org-agenda-get-closed): List each clocking entry. (org-set-tags): Only tabify before tags if indent-tabs-mode is t. (org-special-ctrl-k): New option. (org-kill-line): New function. (org-archive-all-done): Fixed incorrect number of stars in regexp. (org-refile-get-location): New function. (org-refile-goto-last-stored): New function. (org-global-tags-completion-table): Add the value of org-tag-alist in each buffer, to make sure that also unused tags will be available for completion. (org-columns-edit-value) (org-columns-next-allowed-value): Only update if not in agenda. (org-clocktable-steps): New function. (org-dblock-write:clocktable): Call `org-clocktable-steps'. (org-archive-subtree): Add the outline tree context as a property. (org-closest-date): New optional argument `prefer'. (org-goto-auto-isearch): New option. (org-goto-map, org-get-location): Implement auto-isearch. (org-goto-local-auto-isearch-map): New variable. (org-goto-local-search-forward-headings) (org-goto-local-auto-isearch): New functions

;;; em-glob.el --- extended file name globbing

;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004,
;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.

;; Author: John Wiegley <[e-mail]>

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;; The globbing code used by Eshell closely follows the syntax used by
;; zsh.  Basically, here is a summary of examples:
;;
;;   echo a*       ; anything starting with 'a'
;;   echo a#b      ; zero or more 'a's, then 'b'
;;   echo a##b     ; one or more 'a's, then 'b'
;;   echo a?       ; a followed by any character
;;   echo a*~ab    ; 'a', then anything, but not 'ab'
;;   echo c*~*~    ; all files beginning with 'c', except backups (*~)
;;
;; Recursive globbing is also supported:
;;
;;   echo **/*.c   ; all '.c' files at or under current directory
;;   echo ***/*.c  ; same as above, but traverse symbolic links
;;
;; Using argument predication, the recursive globbing syntax is
;; sufficient to replace the use of 'find <expr> | xargs <cmd>' in
;; most cases.  For example, to change the readership of all files
;; belonging to 'johnw' in the '/tmp' directory or lower, use:
;;
;;   chmod go-r /tmp/**/*(u'johnw')
;;
;; The glob above matches all of the files beneath '/tmp' that are
;; owned by the user 'johnw'.  See [Value modifiers and predicates],
;; for more information about argument predication.

;;; Code:

(eval-when-compile (require 'eshell))
(require 'esh-util)

(defgroup eshell-glob nil
  "This module provides extended globbing syntax, similar what is used
by zsh for filename generation."
  :tag "Extended filename globbing"
  :group 'eshell-module)

;;; User Variables:

(defcustom eshell-glob-load-hook '(eshell-glob-initialize)
  "*A list of functions to run when `eshell-glob' is loaded."
  :type 'hook
  :group 'eshell-glob)

(defcustom eshell-glob-include-dot-files nil
  "*If non-nil, glob patterns will match files beginning with a dot."
  :type 'boolean
  :group 'eshell-glob)

(defcustom eshell-glob-include-dot-dot t
  "*If non-nil, glob patterns that match dots will match . and .."
  :type 'boolean
  :group 'eshell-glob)

(defcustom eshell-glob-case-insensitive (eshell-under-windows-p)
  "*If non-nil, glob pattern matching will ignore case."
  :type 'boolean
  :group 'eshell-glob)

(defcustom eshell-glob-show-progress nil
  "*If non-nil, display progress messages during a recursive glob.
This option slows down recursive glob processing by quite a bit."
  :type 'boolean
  :group 'eshell-glob)

(defcustom eshell-error-if-no-glob nil
  "*If non-nil, it is an error for a glob pattern not to match.
 This mimcs the behavior of zsh if non-nil, but bash if nil."
  :type 'boolean
  :group 'eshell-glob)

(defcustom eshell-glob-chars-list '(?\] ?\[ ?* ?? ?~ ?\( ?\) ?| ?# ?^)
  "*List of additional characters used in extended globbing."
  :type '(repeat character)
  :group 'eshell-glob)

(defcustom eshell-glob-translate-alist
  '((?\] . "]")
    (?\[ . "[")
    (?^  . "^")
    (??  . ".")
    (?*  . ".*")
    (?~  . "~")
    (?\( . "\\(")
    (?\) . "\\)")
    (?\| . "\\|")
    (?#  . (lambda (str pos)
	     (if (and (< (1+ pos) (length str))
		      (memq (aref str (1+ pos)) '(?* ?# ?+ ??)))
		 (cons (if (eq (aref str (1+ pos)) ??)
			   "?"
			 (if (eq (aref str (1+ pos)) ?*)
			     "*" "+")) (+ pos 2))
	       (cons "*" (1+ pos))))))
  "*An alist for translation of extended globbing characters."
  :type '(repeat (cons character (choice regexp function)))
  :group 'eshell-glob)

;;; Functions:

(defun eshell-glob-initialize ()
  "Initialize the extended globbing code."
  ;; it's important that `eshell-glob-chars-list' come first
  (when (boundp 'eshell-special-chars-outside-quoting)
    (set (make-local-variable 'eshell-special-chars-outside-quoting)
	 (append eshell-glob-chars-list eshell-special-chars-outside-quoting)))
  (add-hook 'eshell-parse-argument-hook 'eshell-parse-glob-chars t t)
  (add-hook 'eshell-pre-rewrite-command-hook
	    'eshell-no-command-globbing nil t))

(defun eshell-no-command-globbing (terms)
  "Don't glob the command argument.  Reflect this by modifying TERMS."
  (ignore
   (when (and (listp (car terms))
	      (eq (caar terms) 'eshell-extended-glob))
     (setcar terms (cadr (car terms))))))

(defun eshell-add-glob-modifier ()
  "Add `eshell-extended-glob' to the argument modifier list."
  (when (memq 'expand-file-name eshell-current-modifiers)
    (setq eshell-current-modifiers
	  (delq 'expand-file-name eshell-current-modifiers))
    ;; if this is a glob pattern than needs to be expanded, then it
    ;; will need to expand each member of the resulting glob list
    (add-to-list 'eshell-current-modifiers
		 '(lambda (list)
		    (if (listp list)
			(mapcar 'expand-file-name list)
		      (expand-file-name list)))))
  (add-to-list 'eshell-current-modifiers 'eshell-extended-glob))

(defun eshell-parse-glob-chars ()
  "Parse a globbing delimiter.
The character is not advanced for ordinary globbing characters, so
that other function may have a chance to override the globbing
interpretation."
  (when (memq (char-after) eshell-glob-chars-list)
    (if (not (memq (char-after) '(?\( ?\[)))
	(ignore (eshell-add-glob-modifier))
      (let ((here (point)))
	(forward-char)
	(let* ((delim (char-before))
	       (end (eshell-find-delimiter
		     delim (if (eq delim ?\[) ?\] ?\)))))
	  (if (not end)
	      (throw 'eshell-incomplete delim)
	    (if (and (eshell-using-module 'eshell-pred)
		     (eshell-arg-delimiter (1+ end)))
		(ignore (goto-char here))
	      (eshell-add-glob-modifier)
	      (prog1
		  (buffer-substring-no-properties (1- (point)) (1+ end))
		(goto-char (1+ end))))))))))

(defvar eshell-glob-chars-regexp nil)

(defun eshell-glob-regexp (pattern)
  "Convert glob-pattern PATTERN to a regular expression.
The basic syntax is:

  glob  regexp   meaning
  ----  ------   -------
  ?      .       matches any single character
  *      .*      matches any group of characters (or none)
  #      *       matches zero or more occurrences of preceding
  ##     +       matches one or more occurrences of preceding
  (x)    \(x\)   makes 'x' a regular expression group
  |      \|      boolean OR within an expression group
  [a-b]  [a-b]   matches a character or range
  [^a]   [^a]    excludes a character or range

If any characters in PATTERN have the text property `eshell-escaped'
set to true, then these characters will match themselves in the
resulting regular expression."
  (let ((matched-in-pattern 0)          ; How much of PATTERN handled
	regexp)
    (while (string-match
	    (or eshell-glob-chars-regexp
		(set (make-local-variable 'eshell-glob-chars-regexp)
		     (format "[%s]+" (apply 'string eshell-glob-chars-list))))
	    pattern matched-in-pattern)
      (let* ((op-begin (match-beginning 0))
	     (op-char (aref pattern op-begin)))
	(setq regexp
	      (concat regexp
		      (regexp-quote
		       (substring pattern matched-in-pattern op-begin))))
	(if (get-text-property op-begin 'escaped pattern)
	    (setq regexp (concat regexp
				 (regexp-quote (char-to-string op-char)))
		  matched-in-pattern (1+ op-begin))
	  (let ((xlat (assq op-char eshell-glob-translate-alist)))
	    (if (not xlat)
		(error "Unrecognized globbing character '%c'" op-char)
	      (if (stringp (cdr xlat))
		  (setq regexp (concat regexp (cdr xlat))
			matched-in-pattern (1+ op-begin))
		(let ((result (funcall (cdr xlat) pattern op-begin)))
		  (setq regexp (concat regexp (car result))
			matched-in-pattern (cdr result)))))))))
    (concat "\\`"
	    regexp
	    (regexp-quote (substring pattern matched-in-pattern))
	    "\\'")))

(defun eshell-extended-glob (glob)
  "Return a list of files generated from GLOB, perhaps looking for DIRS-ONLY.
This function almost fully supports zsh style filename generation
syntax.  Things that are not supported are:

   ^foo        for matching everything but foo
   (foo~bar)   tilde within a parenthesis group
   foo<1-10>   numeric ranges
   foo~x(a|b)  (a|b) will be interpreted as a predicate/modifier list

Mainly they are not supported because file matching is done with Emacs
regular expressions, and these cannot support the above constructs.

If this routine fails, it returns nil.  Otherwise, it returns a list
the form:

   (INCLUDE-REGEXP EXCLUDE-REGEXP (PRED-FUNC-LIST) (MOD-FUNC-LIST))"
  (let ((paths (eshell-split-path glob))
	matches message-shown ange-cache)
    (unwind-protect
	(if (and (cdr paths)
		 (file-name-absolute-p (car paths)))
	    (eshell-glob-entries (file-name-as-directory (car paths))
				 (cdr paths))
	  (eshell-glob-entries (file-name-as-directory ".") paths))
      (if message-shown
	  (message nil)))
    (or (and matches (sort matches #'string<))
	(if eshell-error-if-no-glob
	    (error "No matches found: %s" glob)
	  glob))))

(eval-when-compile
  (defvar matches)
  (defvar message-shown))

;; FIXME does this really need to abuse matches, message-shown?
(defun eshell-glob-entries (path globs &optional recurse-p)
  "Glob the entries in PATHS, possibly recursing if RECURSE-P is non-nil."
  (let* ((entries (ignore-errors
		    (file-name-all-completions "" path)))
	 (case-fold-search eshell-glob-case-insensitive)
	 (glob (car globs))
	 (len (length glob))
	 dirs rdirs
	 incl excl
	 name isdir pathname)
    (while (cond
	    ((and (= len 3) (equal glob "**/"))
	     (setq recurse-p 2
		   globs (cdr globs)
		   glob (car globs)
		   len (length glob)))
	    ((and (= len 4) (equal glob "***/"))
	     (setq recurse-p 3
		   globs (cdr globs)
		   glob (car globs)
		   len (length glob)))))
    (if (and recurse-p (not glob))
	(error "'**' cannot end a globbing pattern"))
    (let ((index 1))
      (setq incl glob)
      (while (and (eq incl glob)
		  (setq index (string-match "~" glob index)))
	(if (or (get-text-property index 'escaped glob)
		(or (= (1+ index) len)))
	    (setq index (1+ index))
	  (setq incl (substring glob 0 index)
		excl (substring glob (1+ index))))))
    ;; can't use `directory-file-name' because it strips away text
    ;; properties in the string
    (let ((len (1- (length incl))))
      (if (eq (aref incl len) ?/)
	  (setq incl (substring incl 0 len)))
      (when excl
	(setq len (1- (length excl)))
	(if (eq (aref excl len) ?/)
	    (setq excl (substring excl 0 len)))))
    (setq incl (eshell-glob-regexp incl)
	  excl (and excl (eshell-glob-regexp excl)))
    (if (or eshell-glob-include-dot-files
	    (eq (aref glob 0) ?.))
	(unless (or eshell-glob-include-dot-dot
		    (cdr globs))
	  (setq excl (if excl
			 (concat "\\(\\`\\.\\.?\\'\\|" excl "\\)")
		       "\\`\\.\\.?\\'")))
      (setq excl (if excl
		     (concat "\\(\\`\\.\\|" excl "\\)")
		   "\\`\\.")))
    (when (and recurse-p eshell-glob-show-progress)
      (message "Building file list...%d so far: %s"
	       (length matches) path)
      (setq message-shown t))
    (if (equal path "./") (setq path ""))
    (while entries
      (setq name (car entries)
	    len (length name)
	    isdir (eq (aref name (1- len)) ?/))
      (if (let ((fname (directory-file-name name)))
	    (and (not (and excl (string-match excl fname)))
		 (string-match incl fname)))
	  (if (cdr globs)
	      (if isdir
		  (setq dirs (cons (concat path name) dirs)))
	    (setq matches (cons (concat path name) matches))))
      (if (and recurse-p isdir
	       (or (> len 3)
		   (not (or (and (= len 2) (equal name "./"))
			    (and (= len 3) (equal name "../")))))
	       (setq pathname (concat path name))
	       (not (and (= recurse-p 2)
			 (file-symlink-p
			  (directory-file-name pathname)))))
	  (setq rdirs (cons pathname rdirs)))
      (setq entries (cdr entries)))
    (setq dirs (nreverse dirs)
	  rdirs (nreverse rdirs))
    (while dirs
      (eshell-glob-entries (car dirs) (cdr globs))
      (setq dirs (cdr dirs)))
    (while rdirs
      (eshell-glob-entries (car rdirs) globs recurse-p)
      (setq rdirs (cdr rdirs)))))

(provide 'em-glob)

;;; arch-tag: d0548f54-fb7c-4978-a88e-f7c26f7f68ca
;;; em-glob.el ends here