cgit.sxemacs.org Git - sxemacs/blob - lisp/lisp-initd.el

   1 ;; lisp-initd.el - rc.d inspired configuration management for
   2 ;;                 SXEmacs-lisp
   3 ;;
   4 ;; Copyright (C) 2007, Nelson Ferreira
   5 ;; Maintainer: Nelson Ferreira
   6 ;;
   7 ;; This file is part of SXEmacs
   8 ;;
   9 ;; All rights reserved.
  10 ;;
  11 ;; Redistribution and use in source and binary forms, with or without
  12 ;; modification, are permitted provided that the following conditions
  13 ;; are met:
  14 ;;
  15 ;; Redistributions of source code must retain the above copyright
  16 ;; notice, this list of conditions and the following disclaimer.
  17 ;;
  18 ;; Redistributions in binary form must reproduce the above copyright
  19 ;; notice, this list of conditions and the following disclaimer in the
  20 ;; documentation and/or other materials provided with the
  21 ;; distribution.
  22 ;;
  23 ;; Neither the name of the <ORGANIZATION> nor the names of its
  24 ;; contributors may be used to endorse or promote products derived
  25 ;; from this software without specific prior written permission.
  26 ;;
  27 ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  28 ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  29 ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
  30 ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  31 ;; COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
  32 ;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
  33 ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  34 ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  35 ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
  36 ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
  37 ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
  38 ;; OF THE POSSIBILITY OF SUCH DAMAGE.
  39
  40 ;; This file is dumped with SXEmacs
  41
  42 (require 'cl-extra)
  43 ;(require 'bytecomp)
  44 ;(require 'byte-optimize)
  45 ;(require 'bytecomp-runtime)
  46
  47 (defvar lisp-initd-dir (file-name-as-directory
  48                         (expand-file-name "init.d" user-init-directory))
  49   "The default directory for the init files.")
  50
  51 (defvar lisp-initd-prefix  ""
  52   "The default prefix for the compiled init file.")
  53
  54 (defvar lisp-initd-keep-elisp t
  55   "If TRUE the initd resulting lisp file is kept.
  56 Only takes effect when `lisp-initd-byte-compile-elisp' is non-nil.")
  57
  58 (defvar lisp-initd-byte-compile-elisp t
  59   "If TRUE the initd lisp is byte-compiled.")
  60
  61 (defvar lisp-initd-kill-compile-log nil
  62   "Kill the byte-compile Compile Log buffers")
  63
  64
  65 (defvar lisp-initd-gather-func #'directory-files
  66   "Function used to gather the files used in init.  For acceptable
  67 arguments see `directory-files'.  The function is expected to return a
  68 sorted list of absolute pathnames, accept and honor the MATCH argument
  69 and return files only.")
  70
  71 (defun lisp-initd-compile (&optional dir prefix do-init)
  72   "Compile the lisp files in DIR into a file named {DIR}/{PREFIX}init.d.el.
  73 If DIR is nil `lisp-initd-dir' is used.
  74 If PREFIX is nil `lisp-initd-prefix' is used.
  75 If DO-INIT is non-nil the file is loaded."
  76   (let* ((initd-dir    (or dir lisp-initd-dir))
  77          (initd-file   (concat (or prefix lisp-initd-prefix)
  78                               "init.d"))
  79          (initd-el     (expand-file-name (concat initd-file ".el")
  80                                          (paths-construct-path
  81                                           (list initd-dir ".."))))
  82          (initd-elc    (concat initd-el "c"))
  83          (initd-files  (funcall lisp-initd-gather-func initd-dir
  84                                 t "^.*\.el$" nil t))
  85          (init-file     (if lisp-initd-byte-compile-elisp initd-elc initd-el))
  86          init-buffer)
  87
  88     ;; No use in keeping an outdate byte-compiled file...
  89     (when (and (file-exists-p initd-el)
  90                (file-exists-p initd-elc)
  91                (file-newer-than-file-p initd-el initd-elc))
  92       (delete-file initd-elc))
  93
  94     ;; If a file (or the directory itself) is newer than the existing
  95     ;; file then
  96     (when (some #'(lambda (file) (file-newer-than-file-p file init-file))
  97                 (cons initd-dir initd-files))
  98       ;; No matter what the elc is outdated now..
  99       (when (file-exists-p initd-elc) (delete-file initd-elc))
 100       (when (file-exists-p initd-elc) (delete-file initd-el))
 101       (message "Recompiling init files....")
 102       (setq init-buffer (generate-new-buffer (concat "*" initd-el "*")))
 103       (with-current-buffer init-buffer
 104         (set-visited-file-name initd-el)
 105         (insert ";; This is an automatically generated file.\n"
 106                 ";; DO NOT EDIT\n"
 107                 ";;\n")
 108         (insert "(message \"Compiled " initd-dir " loading started\")\n")
 109         (mapc
 110          #'(lambda (current)
 111              (condition-case err
 112                  (insert "(condition-case err (progn\n"
 113                          ";; ------------------------------------\n"
 114                          ";; " current "\n"
 115                          (save-excursion
 116                            (save-restriction
 117                              (with-temp-buffer
 118                                (insert-file-contents current)
 119                                (eval-buffer)
 120                                (buffer-substring))))
 121                          "\n"
 122                          ";; ----------------------------------\n"
 123                          ")\n"
 124                          "(error (message \"Error loading " current
 125                          ": \\\"%S\\\" (signal:\'%S\' . data:\'%S\')\" "
 126                          "err (car err) (cdr err))))\n"
 127                          ";; ----------------------------------\n\n")
 128                (error
 129                 (progn
 130                   (insert "(message \"\\\"" current
 131                           "\\\" not inserted "
 132                           (replace-regexp-in-string
 133                            "\"" "\\\""
 134                            (format (concat "due to syntax error: %S"
 135                                            " (signal:%S . data:%S)")
 136                                    err (car err) (cdr err)))
 137                           "\")\n")
 138                   (message
 139                    "\"%S\" not inserted due to syntax error: %S (signal:%S . data:%S)"
 140                    current err (car err) (cdr err))))))
 141          initd-files)
 142         (insert "(message \"Compiled " initd-dir " loading finished\")\n")
 143         (save-buffer init-buffer)))
 144     (when (and lisp-initd-byte-compile-elisp
 145                (file-newer-than-file-p initd-el initd-elc))
 146       (ignore-errors
 147         (progn
 148           (byte-compile-file initd-el)
 149           (when lisp-initd-kill-compile-log
 150             (kill-buffer (get-buffer "*Compile-Log*"))
 151             (kill-buffer (get-buffer "*Compile-Log-Show*")))
 152           (delete-other-windows)
 153           (unless lisp-initd-keep-elisp
 154             (delete-file initd-el)))))
 155     (when (and do-init (null init-buffer))
 156       (load init-file nil nil t))))
 157
 158
 159 (defun lisp-initd-compile-and-load (&optional dir prefix)
 160   "Compile and load the lisp files in DIR into a file named {DIR}/{PREFIX}init.d.el.
 161
 162 If DIR, a string, is omitted `lisp-initd-dir' is used.  DIR can be
 163 either a complete path, or the last element of a path.  If the latter,
 164 DIR is expanded against the _parent_ directory of `lisp-initd-dir'.
 165
 166 Optional prefix arg, PREFIX is a string that is prepended to the generated
 167 filename to be loaded.  If it is omitted, `lisp-initd-prefix' is used.
 168
 169 See `lisp-initd-compile'."
 170   (interactive (list (expand-file-name (read-directory-name
 171                                         "initd directory: " user-init-directory
 172                                         lisp-initd-dir t))))
 173   (when dir
 174     (unless (string-match "/" dir)
 175       (setq dir (file-name-as-directory
 176                  (expand-file-name dir (paths-construct-path
 177                                         (list lisp-initd-dir "..")))))))
 178   (when current-prefix-arg
 179     (setq prefix (read-string "Prefix: ")))
 180
 181   (lisp-initd-compile dir prefix t))
 182
 183 (provide 'lisp-initd)
 184