aliator.el 1.2

[Andreas Roehler]

;;; aliator.el --- 

;; Version: 1.2

;; Copyright (C) 2006  Andreas Roehler

;; Author: Andreas Roehler <address@hidden>
;; Keywords: convenience

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

;; This file 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.

;; Changes 

;; Now an arbitrary number of `no-alias' strings may be
;; specified, thus excluding indicated functions from
;; being processed. Listed change-strings row up in
;; different order from last version to that
;; purpose. Respective changes in code.

;;; Commentary:

;; Defines aliases from given command prefix names, in
;; order to enable listing of the (now) expanded names
;; together with the others, already beginning with the
;; mode-name.

;; Automatizes the process of defining aliases while
;; following some rules.

;; This rules provide for cases were it seems suitable:
;; for example in outline-mode most of the commands
;; start with the prefix `outline-', to that `M-
;; outline- tab' lists the commands. Unfortunately very
;; important commands--hide-entry and show-entry--don't
;; start with `outline-'and are not visible that way.

;; That's a case were aliator helps with alias
;; definitions in an output-buffer:

;; (defalias 'outline-hide-entry 'hide-entry) 
;; (defalias 'outline-show-entry 'show-entry)

;; You just have to eval the output-buffer to install it.

;; Of course normally you must specify the file to
;; process; output.el is processed per default as an
;; example.

;; There are cases you may not wish to prepend an new
;; prefix, but replace the old. Also you may wish to
;; make exceptions.

;; Editing in xml-mode (there are several available
;; meanwhile) it happened, that the commands mostly
;; started with `sgml-'. So trying `M-x xml-' had not
;; the expected effect. Handling it the way shown above
;; would result in long command-names starting with
;; `xml-sgml-'. Here it seems better to replace `sgml-'
;; in the alias name with `xml-'.

;; To process this, you have to specify a list with
;; five slots

;;  "file to process" "prefix" "replace-prefix"
;;  "suffix" "no-alias"

;; There may be even more strings in such a list: every
;; string after "no-alias" will be handled as
;; "no-alias", so you may specify any number of them.

;; You may do that via `M-x customize aliator-list-4'.

;; The customized list to process would be for instance

;; ("~/emacs/lisp/textmodes/sgml-mode.el" "xml" "sgml" "" "")

;; Slot 5 - "no-alias" here is empty. 

;; In example below it's filled too, because the file to
;; process--sgml-mode.el--contains functions designed
;; for a html-mode. Probably you will not changes this
;; prefix, nor need an alias with `xml-' prepended
;; before `html-'.

;; So it's customized as 

;; ("~/emacs/lisp/textmodes/sgml-mode.el" "xml" "sgml" "" "html")

;; Aliator might be useful to adapt lisp-files which
;; are not distributed with Emacs. Functions then
;; mostly start with arbitrarily chosen strings to
;; avoid clashes with emacs-functions already in
;; use. However, it's obnoxious not to get listed them
;; in their context, also calling them is not
;; convenient. So I move this personalism from the
;; beginning to the end of a function name, from prefix
;; to suffix. With mell.el for example this looks like

;; ("/usr/local/share/emacs/site-lisp/mell/mell.el" "" "mell" "mell" "")

;; Edit `aliator-list-1' and/or
;; `aliator-list-4' according to your needs

;; Or extend the code with further aliator-list-n
;; processed

;; ToDo: aliator-report-consum

;;; Code:

(defcustom aliator-list-1
  '(
    ("/usr/local/share/emacs/22.0.50/lisp/outline.el" "outline" "" "" ""))
  "A list of lists specifying filenames and the way to get aliases from.
Add or remove lists, whose elements are:
 \"file to process\" \"prefix\"  \"replace-prefix\" \"suffix\" \"no-alias\"
where
`prefix' indicates the new name-prefix wherefrom expansion will work, 
`replace-prefix' handles cases where it seems appropriate to provide an `alias' 
replacing the first part of the function-name, as `xml-' instead of `sgml-'; 
might also be the empty string
Each list must specify five strings, the latter three might be
empty.
`suffix' the new suffix, 
`no-alias' the exception, where no alias should be defined. You may specify an 
arbitrary number of `no-alias' strings following this one, to exclude thus 
several function-names from being processed.
"
  :type '(alist :value-type (repeat string))
  ;;  :options '
  :group 'aliator)

(defcustom aliator-list-4
  '(("~/emacs/lisp/textmodes/sgml-mode.el" "xml" "sgml" "" "html")
    ("~/emacs/lisp/abbrev.el" "abbrev" "" "" "")
    ("~/emacs/lisp/find-dired.el" "dired" "" "" "")
    ("/usr/local/share/emacs/site-lisp/mell/mell.el" "" "mell" "mell" ""))
  "A list of files with assigned strings to process in order to get aliases.
Add or remove lists, whose elements are:
 \"file to process\" \"prefix\"  \"replace-prefix\" \"suffix\" \"no-alias\" 
See `aliator-list-1' for further documentation"
  :type '(alist :value-type (repeat string))
  :group 'aliator)

;; In some circumstances it may be faster and
;; convenient to change variables not via customize but
;; via setq: then de-comment this, edit and eval
;; something like that:.

;; (setq aliator-list-4
;; '(
;;     ("~/emacs/lisp/textmodes/sgml-mode.el" "xml" "sgml" "" "html" "htm")
;;     ))

;; This needs still to be set into effect 
(defcustom aliator-report-consum  nil 
 "Report the amount of memory and conses consumed due defined new aliases" 

:type 'boolean
:group 'aliator)

(defun aliator (&optional arg) 
  "Provides `alias'-defs following a PREFIX and specifications.
Works at function names not starting already with that prefix.
Normalizes command names to that `M-x mode-name- TAB' - now lists
all functions available, even if they don't start with that
PREFIX originally.  See the default `aliator-list-1' for
documentation how to edit that list.
With arg: use `aliator-list-4' to process
When calling from a programm, use
"
  (interactive "p")
  (set-buffer (get-buffer-create "newalias"))
  (erase-buffer)
  (let* ((argument (if arg
                       (prefix-numeric-value arg) 1))
         (newalias-list
          (cond ((eq 1 argument)
                 aliator-list-1)
                ((eq 4 argument)
                 aliator-list-4))))
    ;; you may specfiy more aliator-list-n
    ;; to call here with numeric prefix
    ;; args
    (while newalias-list
      (let (
            (file
             (caar newalias-list))
            (prefix
             (cadr (car newalias-list)))
            (replace-prefix 
             (car (nthcdr 2 (car newalias-list))))
            (suffix 
             (car (nthcdr 3 (car newalias-list))))
            (no-alias
             (nthcdr 4 (car newalias-list))))
        ;;      (cdr (car newalias-list))))
        (aliator-intern file prefix no-alias replace-prefix suffix))
      (setq newalias-list (cdr newalias-list)))
    (switch-to-buffer "newalias")
    (if (eq 0 (buffer-size))
        (error "Nothing to do? Can't make a proposal to define new aliases.")
      (message "%s" "`M-x eval-buffer' to install these aliases"))))

(defun aliator-intern (file prefix no-alias replace-prefix suffix)
  "To call from a programm, also usable directly"
  (if (not (file-readable-p file))
      (message "File not readable: %s" file)
    (find-file file)
    (message "Processing %s " (buffer-name))
    (goto-char (point-min))
    (save-excursion 
      (eval-buffer)
      (while (and
              newalias-list
              (switch-to-buffer (current-buffer)) 
              (re-search-forward "^(defun \\([A-Za-z0-9\-]+\\)" (point-max) t 
1))
        (let ((akt-fn (match-string 1))
              (fn-first-part (substring (match-string 1) 0 (string-match "-" 
(match-string 1)))))
          ;; if the function name already starts with the
          ;; wished name or `no-alias' is set, do nothing
          (unless (or (string= fn-first-part prefix)
                      (member fn-first-part no-alias))
            ;; with replace-prefix there are three
            ;; possibilities:
            ;; - simple replace if there is a new one,
            ;; - replace par "" i.e. delete,
            ;; - delete prefix and concatenate a suffix
            (if (string= fn-first-part replace-prefix)
                (progn
                  (setq neualias
                        (if (< 0 (length prefix))
                            (concat prefix (substring akt-fn (string-match "-" 
akt-fn)))
                          (substring akt-fn (1+ (string-match "-" akt-fn)))))
                  (when
                      (< 0 (length suffix))
                    (setq neualias (concat neualias"-"suffix)))
                  (aliator-ausgabe neualias))
              (let*
                  ((alt-alias (split-string akt-fn "-"))
                   (alias-ohne-neualias (remove prefix alt-alias))
                   (alias-ohne-suffix (remove suffix alias-ohne-neualias))
                   ;; avoid repeats in names as dired-look-dired
                   (alias-ohne-doppel (delete-dups alias-ohne-suffix))
                   alias-verkettet)
                (dolist (teil alias-ohne-doppel)
                  (setq alias-verkettet (concat alias-verkettet "-"(format "%s" 
teil))))
                (if (< 0 (length prefix))
                    (setq neualias (concat prefix alias-verkettet))
                  (setq neualias (substring alias-verkettet 1)))
                (when (< 0 (length suffix))
                  (setq neualias (concat neualias"-"suffix)))
                (aliator-ausgabe neualias)))))))
    (kill-buffer (current-buffer))))

(defun aliator-ausgabe (neualias)
  (if (functionp neualias)
      (message " %s" "Function already exists")
    (save-excursion
      (set-buffer "newalias")
      (switch-to-buffer (current-buffer))
      (insert "(defalias '"neualias "\t'"akt-fn")""\n"))))

(provide 'aliator)
;;; aliator.el ends here