emacs/lisp/cedet/ede/linux.el

;;; ede/linux.el --- Special project for Linux

;; Copyright (C) 2008-2014 Free Software Foundation, Inc.

;; Author: Eric M. Ludlam <eric@siege-engine.com>

;; 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 of the License, 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.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; Provide a special project type just for Linux, cause Linux is special.
;;
;; Identifies a Linux project automatically.
;; Speedy ede-expand-filename based on extension.
;; Pre-populates the preprocessor map from lisp.h
;;
;; ToDo :
;; * Add "build" options.
;; * Add texinfo lookup options.
;; * Add website

(eval-when-compile (require 'cl))

(require 'ede)
(require 'ede/make)

(declare-function semanticdb-file-table-object "semantic/db")
(declare-function semanticdb-needs-refresh-p "semantic/db")
(declare-function semanticdb-refresh-table "semantic/db")

;;; Code:
(defgroup project-linux nil
  "File and tag browser frame."
  :group 'tools
  :group 'ede
  :version "24.3")

(defcustom project-linux-build-directory-default 'ask
  "Build directory."
  :version "24.4"
  :group 'project-linux
  :type '(choice (const :tag "Same as source directory" same)
                 (const :tag "Ask the user" ask)))

(defcustom project-linux-architecture-default 'ask
  "Target architecture to assume when not auto-detected."
  :version "24.4"
  :group 'project-linux
  :type '(choice (string :tag "Architecture name")
                 (const :tag "Ask the user" ask)))


(defcustom project-linux-compile-target-command (concat ede-make-command " -k -C %s SUBDIRS=%s")
  "*Default command used to compile a target."
  :group 'project-linux
  :type 'string)

(defcustom project-linux-compile-project-command (concat ede-make-command " -k -C %s")
  "*Default command used to compile a project."
  :group 'project-linux
  :type 'string)

(defun ede-linux-version (dir)
  "Find the Linux version for the Linux src in DIR."
  (let ((buff (get-buffer-create " *linux-query*")))
    (with-current-buffer buff
      (erase-buffer)
      (setq default-directory (file-name-as-directory dir))
      (insert-file-contents "Makefile" nil 0 512)
      (goto-char (point-min))
      (let (major minor sub)
	(re-search-forward "^VERSION *= *\\([0-9.]+\\)")
	(setq major (match-string 1))
	(re-search-forward "^PATCHLEVEL *= *\\([0-9.]+\\)")
	(setq minor (match-string 1))
	(re-search-forward "^SUBLEVEL *= *\\([0-9.]+\\)")
	(setq sub (match-string 1))
	(prog1
	    (concat major "." minor "." sub)
	  (kill-buffer buff)
	  )))))

(defclass ede-linux-project (ede-project)
  ((build-directory :initarg :build-directory
                    :type string
                    :documentation "Build directory.")
   (architecture :initarg :architecture
                 :type string
                 :documentation "Target architecture.")
   (include-path :initarg :include-path
                 :type list
                 :documentation "Include directories.
Contains both common and target architecture-specific directories."))
  "Project Type for the Linux source code."
  :method-invocation-order :depth-first)


(defun ede-linux--get-build-directory (dir)
  "Detect build directory for sources in DIR.
If DIR has not been used as a build directory, fall back to
`project-linux-build-directory-default'."
  (or
   ;; detected build on source directory
   (and (file-exists-p (expand-file-name ".config" dir)) dir)
   ;; use configuration
   (case project-linux-build-directory-default
     (same dir)
     (ask (read-directory-name "Select Linux' build directory: " dir)))))


(defun ede-linux--get-archs (dir)
  "Returns a list of architecture names found in DIR."
  (let ((archs-dir (expand-file-name "arch" dir))
        archs)
    (when (file-directory-p archs-dir)
      (mapc (lambda (elem)
              (when (and
                     (not (string= elem "."))
                     (not (string= elem ".."))
                     (not (string= elem "x86_64")) ; has no separate sources
                     (file-directory-p
                      (expand-file-name elem archs-dir)))
                (add-to-list 'archs elem t)))
            (directory-files archs-dir)))
    archs))


(defun ede-linux--detect-architecture (dir)
  "Try to auto-detect the architecture as configured in DIR.
DIR is Linux' build directory. If it cannot be auto-detected,
returns `project-linux-architecture-default'."
  (let ((archs-dir (expand-file-name "arch" dir))
        (archs (ede-linux--get-archs dir))
        arch found)
    (or (and
         archs
         ;; Look for /arch/<arch>/include/generated
         (progn
           (while (and archs (not found))
             (setq arch (car archs))
             (when (file-directory-p
                    (expand-file-name (concat arch "/include/generated")
                                      archs-dir))
               (setq found arch))
             (setq archs (cdr archs)))
           found))
       project-linux-architecture-default)))

(defun ede-linux--get-architecture (dir bdir)
  "Try to auto-detect the architecture as configured in BDIR.
Uses `ede-linux--detect-architecture' for the auto-detection. If
the result is `ask', let the user choose from architectures found
in DIR."
  (let ((arch (ede-linux--detect-architecture bdir)))
    (case arch
      (ask
       (completing-read "Select target architecture: "
                        (ede-linux--get-archs dir)))
      (t arch))))


(defun ede-linux--include-path (dir bdir arch)
  "Returns a list with include directories.
Returned directories might not exist, since they are not created
until Linux is built for the first time."
  (map 'list
       (lambda (elem) (format (concat (car elem) "/" (cdr elem)) arch))
       ;; XXX: taken from the output of "make V=1"
       (list (cons  dir "arch/%s/include")
             (cons bdir "arch/%s/include/generated")
             (cons  dir "include")
             (cons bdir "include")
             (cons  dir "arch/%s/include/uapi")
             (cons bdir "arch/%s/include/generated/uapi")
             (cons  dir "include/uapi")
             (cons bdir "include/generated/uapi"))))

;;;###autoload
(defun ede-linux-load (dir &optional rootproj)
  "Return an Linux Project object if there is a match.
Return nil if there isn't one.
Argument DIR is the directory it is created for.
ROOTPROJ is nil, since there is only one project."
  ;; Doesn't already exist, so let's make one.
  (let* ((bdir (ede-linux--get-build-directory dir))
	 (arch (ede-linux--get-architecture dir bdir))
	 (include-path (ede-linux--include-path dir bdir arch)))
    (ede-linux-project
     "Linux"
     :name "Linux"
     :version (ede-linux-version dir)
     :directory (file-name-as-directory dir)
     :file (expand-file-name "scripts/ver_linux"
			     dir)
     :build-directory bdir
     :architecture arch
     :include-path include-path)))

;;;###autoload
(ede-add-project-autoload
 (ede-project-autoload "linux"
		       :name "LINUX ROOT"
		       :file 'ede/linux
		       :proj-file "scripts/ver_linux"
		       :load-type 'ede-linux-load
		       :class-sym 'ede-linux-project
		       :new-p nil
		       :safe-p t)
 'unique)

(defclass ede-linux-target-c (ede-target)
  ()
  "EDE Linux Project target for C code.
All directories need at least one target.")

(defclass ede-linux-target-misc (ede-target)
  ()
  "EDE Linux Project target for Misc files.
All directories need at least one target.")

(defmethod initialize-instance ((this ede-linux-project)
				&rest fields)
  "Make sure the targets slot is bound."
  (call-next-method)
  (unless (slot-boundp this 'targets)
    (oset this :targets nil)))

;;; File Stuff
;;
(defmethod ede-project-root-directory ((this ede-linux-project)
				       &optional file)
  "Return the root for THIS Linux project with file."
  (ede-up-directory (file-name-directory (oref this file))))

(defmethod ede-project-root ((this ede-linux-project))
  "Return my root."
  this)

(defmethod ede-find-subproject-for-directory ((proj ede-linux-project)
					      dir)
  "Return PROJ, for handling all subdirs below DIR."
  proj)

;;; TARGET MANAGEMENT
;;
(defun ede-linux-find-matching-target (class dir targets)
  "Find a target that is a CLASS and is in DIR in the list of TARGETS."
  (let ((match nil))
    (dolist (T targets)
      (when (and (object-of-class-p T class)
		 (string= (oref T :path) dir))
	(setq match T)
      ))
    match))

(defmethod ede-find-target ((proj ede-linux-project) buffer)
  "Find an EDE target in PROJ for BUFFER.
If one doesn't exist, create a new one for this directory."
  (let* ((ext (file-name-extension (buffer-file-name buffer)))
	 (cls (cond ((not ext)
		     'ede-linux-target-misc)
		    ((string-match "c\\|h" ext)
		     'ede-linux-target-c)
		    (t 'ede-linux-target-misc)))
	 (targets (oref proj targets))
	 (dir default-directory)
	 (ans (ede-linux-find-matching-target cls dir targets))
	 )
    (when (not ans)
      (setq ans (make-instance
		 cls
		 :name (file-name-nondirectory
			(directory-file-name dir))
		 :path dir
		 :source nil))
      (object-add-to-list proj :targets ans)
      )
    ans))

;;; UTILITIES SUPPORT.
;;
(defmethod ede-preprocessor-map ((this ede-linux-target-c))
  "Get the pre-processor map for Linux C code.
All files need the macros from lisp.h!"
  (require 'semantic/db)
  (let* ((proj (ede-target-parent this))
	 (root (ede-project-root proj))
	 (versionfile (ede-expand-filename root "include/linux/version.h"))
	 (table (when (and versionfile (file-exists-p versionfile))
		  (semanticdb-file-table-object versionfile)))
	 (filemap '( ("__KERNEL__" . "")
		     ))
	 )
    (when table
      (when (semanticdb-needs-refresh-p table)
	(semanticdb-refresh-table table))
      (setq filemap (append filemap (oref table lexical-table)))
      )
    filemap
    ))

(defun ede-linux-file-exists-name (name root subdir)
  "Return a file name if NAME exists under ROOT with SUBDIR in between."
  (let ((F (expand-file-name name (expand-file-name subdir root))))
    (when (file-exists-p F) F)))

(defmethod ede-expand-filename-impl ((proj ede-linux-project) name)
  "Within this project PROJ, find the file NAME.
Knows about how the Linux source tree is organized."
  (let* ((ext (file-name-extension name))
         (root (ede-project-root proj))
         (dir (ede-project-root-directory root))
         (bdir (oref proj build-directory))
         (F (cond
             ((not ext) nil)
             ((string-match "h" ext)
              (let ((dirs (oref proj include-path))
                    found)
                (while (and dirs (not found))
                  (setq found
                        (or (ede-linux-file-exists-name name bdir (car dirs))
                           (ede-linux-file-exists-name name dir (car dirs))))
                  (setq dirs (cdr dirs)))
                found))
             ((string-match "txt" ext)
              (ede-linux-file-exists-name name dir "Documentation"))
             (t nil))))
    (or F (call-next-method))))

;;; Command Support
;;
(defmethod project-compile-project ((proj ede-linux-project)
				    &optional command)
  "Compile the entire current project.
Argument COMMAND is the command to use when compiling."
  (let* ((dir (ede-project-root-directory proj)))

    (require 'compile)
    (if (not project-linux-compile-project-command)
	(setq project-linux-compile-project-command compile-command))
    (if (not command)
	(setq command
	      (format
	       project-linux-compile-project-command
	       dir)))

    (compile command)))

(defmethod project-compile-target ((obj ede-linux-target-c) &optional command)
  "Compile the current target.
Argument COMMAND is the command to use for compiling the target."
  (let* ((proj (ede-target-parent obj))
	 (root (ede-project-root proj))
	 (dir (ede-project-root-directory root))
	 (subdir (oref obj path)))

    (require 'compile)
    (if (not project-linux-compile-project-command)
	(setq project-linux-compile-project-command compile-command))
    (if (not command)
	(setq command
	      (format
	       project-linux-compile-target-command
	       dir subdir)))

    (compile command)))

(defmethod project-rescan ((this ede-linux-project))
  "Rescan this Linux project from the sources."
  (let* ((dir (ede-project-root-directory this))
	 (bdir (ede-linux--get-build-directory dir))
	 (arch (ede-linux--get-architecture dir bdir))
	 (inc (ede-linux--include-path dir bdir arch))
	 (ver (ede-linux-version dir)))
    (oset this version ver)
    (oset this :build-directory bdir)
    (oset this :architecture arch)
    (oset this :include-path inc)
    ))

(provide 'ede/linux)

;; Local variables:
;; generated-autoload-file: "loaddefs.el"
;; generated-autoload-load-name: "ede/linux"
;; End:

;;; ede/linux.el ends here