cgit.sxemacs.org Git - packages/blob - xemacs-packages/semantic/semanticdb-system.el

   1 ;;; semanticdb-system.el --- Build a file DB for some system files.
   2
   3 ;;; Copyright (C) 2002, 2003, 2004, 2005 Eric M. Ludlam
   4
   5 ;; Author: Eric M. Ludlam <zappo@gnu.org>
   6 ;; Keywords: tags
   7 ;; X-RCS: $Id: semanticdb-system.el,v 1.1 2007-11-26 15:10:48 michaels Exp $
   8
   9 ;; This file is not part of GNU Emacs.
  10
  11 ;; Semanticdb is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; This software is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25 ;;
  26 ;;; Commentary:
  27 ;;
  28 ;; A system database is a file based DB which contains tags from a
  29 ;; system.  These files are ONLY ever loaded in, and can only be written
  30 ;; using a set of user initiated scripts.
  31 ;;
  32
  33 (require 'semanticdb-file)
  34 (require 'eieio-opt)
  35
  36 ;;;###autoload
  37 (defcustom semanticdb-default-system-save-directory
  38   ;; Leave this obvious for now.  Maybe hide it later.
  39   (expand-file-name "~/.semanticdb")
  40   "*Directory name where semantic cache files for system headers are stored.
  41 System files cannot have caches stored near them because users rarely have
  42 write permission to such paths."
  43   :group 'semanticdb
  44   :type '(choice :tag "System-Save-Directory"
  45                  :menu-tag "System-Save-Directory"
  46                  (const :tag "Use current directory" :value nil)
  47                  (directory)))
  48
  49 (defcustom semanticdb-system-database-warn-level 50
  50   "*Number of files to be added to a system DB that causes us to warn.
  51 If this number is exceeded, warn the users that it could take a while."
  52   :group 'semanticdb
  53   :type 'boolean)
  54
  55 (defvar semanticdb-system-force-save nil
  56   "When non-nil, the system DB will save itself.
  57 Do not set this to non-nil unless you building a system table for
  58 the first time.")
  59
  60 (defvar semanticdb-database-being-created nil
  61   "Database currently being created.")
  62
  63 ;;; Code:
  64 (defclass semanticdb-project-database-system (semanticdb-project-database-file)
  65   ((file-header-line :initform
  66                      ";; SEMANTICDB Tags save file for system libraries")
  67    (file-match-regex :allocation :class
  68                      :type string
  69                      :documentation
  70                      "Regular expression used to match files names for this database.
  71 When building new databases, only matching files will be included.")
  72    (major-modes :allocation :class
  73                 :type list
  74                 :documentation
  75                 "List of major modes this database is useful to.
  76 Thus, C header files are useful to `c-mode', and to `c++-mode'.")
  77    ;; Provide an init arg for this item so that it will
  78    ;; be saved in the file.
  79    (reference-directory :initarg :reference-directory)
  80    )
  81   "Database of file tables for system libraries saved to disk."
  82   :abstract t)
  83
  84 (defmethod semanticdb-create-database :STATIC ((dbc semanticdb-project-database-system)
  85                                                directory)
  86   "Create a new semantic database for DIRECTORY and return it.
  87 If a database for DIRECTORY has already been loaded, return it.
  88 If a database for DIRECTORY exists, then load that database, and return it.
  89 If DIRECTORY doesn't exist, create a new one."
  90   ;; System databases span directories.  Be smart about creation.
  91   (or semanticdb-database-being-created
  92       (call-next-method)))
  93
  94 (defmethod semanticdb-write-directory-p
  95   ((obj semanticdb-project-database-system))
  96   "Return non-nil if OBJ should be written to disk.
  97 Uses `semanticdb-persistent-path' to determine the return value."
  98   semanticdb-system-force-save)
  99
 100 (defmethod semanticdb-cache-filename :STATIC
 101   ((dbclass semanticdb-project-database-system) path)
 102   "For DBCLASS, return a file to a cache file belonging to PATH.
 103 This could be a cache file in the current directory, or an encoded file
 104 name in a secondary directory."
 105   ;; This variable hack re-uses logic for file based databases.
 106   ;; Not too purty, but ok for now.
 107   (let ((semanticdb-default-save-directory
 108          semanticdb-default-system-save-directory))
 109     (call-next-method)))
 110
 111 ;;; User initialization
 112 ;;
 113 (defvar semanticdb-system-database-query-history nil
 114   "History variable when asking for a type of system database.")
 115
 116 ;;;###autoload
 117 (defun semanticdb-create-system-database (path &optional class)
 118   "Create a system database starting at PATH.
 119 PATH should be a top level directory for a series of files containing
 120 declarations for SYSTEM files.  In C, this would be header filaes.
 121 CLASS is the class for the database to create.  Only child classes
 122 of symbol `semanticdb-project-database-system' are accepted."
 123   (interactive "DPath to system files: ")
 124   ;; Make sure there is a / at the end.
 125   (setq path (semanticdb-fix-pathname path))
 126   ;; Make sure storage is available
 127   (if (not semanticdb-default-system-save-directory)
 128       (if (y-or-n-p "Specify value for system database storage now? ")
 129           (customize-variable 'semanticdb-default-system-save-directory)
 130         (error ""))
 131     ;; Get a dir if needed
 132     (if (not (file-exists-p semanticdb-default-system-save-directory))
 133         (if (y-or-n-p
 134              (format "Create %s now? " semanticdb-default-system-save-directory))
 135             (make-directory semanticdb-default-system-save-directory)
 136           (error "")))
 137     ;; All set with that path.  Ask about system type.
 138     (if (not class)
 139         (if (interactive-p)
 140             (setq class
 141                   (eieio-read-subclass "System Type: "
 142                                        semanticdb-project-database-system
 143                                        'semanticdb-system-database-query-history
 144                                        t))
 145           (signal 'wrong-type-argument '(class nil))))
 146     (if (not (child-of-class-p class semanticdb-project-database-system))
 147         (signal 'wrong-type-argument (list 'class class)))
 148     ;; Ok!  Just do it!
 149     (semanticdb-load-system-database class path)
 150     ))
 151
 152 ;;;###autoload
 153 (defun semanticdb-load-system-caches ()
 154   "Load all system databases that were previously saved."
 155   (interactive)
 156   (let ((f (directory-files semanticdb-default-system-save-directory
 157                             t (concat semanticdb-default-file-name "$") t)))
 158     (while f
 159       ;; Emacs makes backup files if we save out the systemDB too often.
 160       ;; prevent loading backup files which are icky.
 161       (when (string-match (concat semanticdb-default-file-name "$")
 162                           (car f))
 163         (semanticdb-load-database (car f)))
 164       ;; NOTE FOR THE FUTURE: Verify the system was not expanded for
 165       ;; each.  This may be slow.
 166       (setq f (cdr f)))
 167     ))
 168
 169 (defvar semanticdb-system-db-directory-search-recursed nil
 170   "Track if we recursed for directory files.")
 171
 172 (defmethod semanticdb-load-system-database :STATIC
 173   ((dbclass semanticdb-project-database-system) path)
 174   "Load a system database of type DBCLASS starting at PATH.
 175 PATH should be a top level directory for a series of files containing
 176 declarations for SYSTEM files.  In C, this would be header files.
 177 Only files in PATH matching DBCLASS' regular expression  will be loaded
 178 and parsed. After the database is created, save it, and return the DB."
 179   ;; For each file do the following:
 180   ;; 1) If already in database, skip
 181   ;; 2) Setup semanticdb files to make sure new table shows up
 182   ;;    in the system database
 183   ;; 3) Load the file.  Allow normal semantic initialization.
 184   ;; 4) Force a reparse.
 185   ;; 5) Kill file if it wasn't already in a buffer.
 186   (let* ((semanticdb-system-db-directory-search-recursed nil)
 187          (files (semanticdb-collect-matching-filenames
 188                  path (oref-default dbclass file-match-regex)))
 189          (sysdb (semanticdb-create-database dbclass path))
 190          ;; 2) Set up to use this database when loading.
 191          (semanticdb-new-database-class dbclass)
 192          )
 193     (if (and (> (length files) semanticdb-system-database-warn-level)
 194              semanticdb-system-db-directory-search-recursed
 195              (y-or-n-p
 196               (format
 197                "%d files found.  Try again without scanning subdirectories? "
 198                (length files))))
 199         (setq files (semanticdb-collect-matching-filenames
 200                      path (oref-default dbclass file-match-regex) t)))
 201     (when (> (length files) semanticdb-system-database-warn-level)
 202       (if (y-or-n-p
 203            (format
 204             "There are %d files which could a long time to parse.  Proceed? "
 205             (length files)))
 206           nil ;; Okie dokie
 207         (error "")))
 208     (oset sysdb reference-directory path)
 209     (while files
 210       (let ((table (semanticdb-file-table sysdb (car files)))
 211             )
 212         ;; 1) Skip if loaded
 213         (unless (and table (oref table tags))
 214           ;; 3) load the file.
 215           (let ((b (get-file-buffer (car files))))
 216             (save-excursion
 217               (set-buffer (find-file-noselect (car files)))
 218               ;; 4) Force a reparse
 219               (semantic-fetch-tags)
 220               ;; At this point, standard semantic actions
 221               ;; have occured.
 222               ;; 5) Kill the buffer
 223               (if (not b) (kill-buffer (current-buffer)))))
 224           ))
 225       (setq files (cdr files)))
 226
 227     ;; All tables are in.  Save this database
 228     (let ((semanticdb-system-force-save t))
 229       (semanticdb-save-db sysdb))
 230
 231     ;; Add it to the search path for major modes.
 232     (let ((m (oref-default sysdb major-modes)))
 233       (while m
 234         (let ((v (mode-local-value (car m) 'semanticdb-project-system-databases))
 235               )
 236           (setq v (cons sysdb v))
 237           ;; NOTE TO SELF; get a set version of `setq-mode-local'.
 238           (eval `(setq-mode-local ,(car m)
 239                                   semanticdb-project-system-databases v)))
 240         (setq m (cdr m))))
 241
 242     ;; Return it.
 243     sysdb))
 244
 245 (defun semanticdb-collect-matching-filenames (path regexp &optional not-recursive)
 246   "Collect a list of all filenames starting at PATH matching REGEXP.
 247 Optional argument NOT-RECURSIVE suggests that this function will not recurse."
 248   (let ((returnfiles nil)
 249         (dirs (list path))
 250         (files nil)
 251         (useregexp (concat "^[^.].*" regexp)))
 252     (while dirs
 253
 254       ;; First, look for more subdirectories.
 255       (when (not not-recursive)
 256         (setq files (directory-files (car dirs) t "^[^.]" t))
 257         (while files
 258           (let ((attr (file-attributes (car files))))
 259             ;; String in (car attr) is a symlink.
 260             (if (and attr (car attr) (not (stringp (car attr))))
 261                 (setq dirs (append dirs (list (car files)))
 262                       semanticdb-system-db-directory-search-recursed t))
 263             (setq files (cdr files)))))
 264
 265       ;; Now get the list of files we are returning.
 266       (setq returnfiles
 267             (append returnfiles (directory-files (car dirs) t useregexp nil)))
 268
 269       (setq dirs (cdr dirs)))
 270     returnfiles))
 271
 272 ;;; Here are a a couple implementations
 273 ;;
 274 (defclass semanticdb-project-database-system-c (semanticdb-project-database-system)
 275   ((file-header-line :initform
 276                      ";; SEMANTICDB Tags save file for system libraries")
 277    ;; Scan for C header files.
 278    (file-match-regex :initform "\\.\\(h\\(h\\|xx\\|pp\\|\\+\\+\\)?\\|H\\)?$")
 279    ;; C modes
 280    (major-modes :initform '(c-mode c++-mode))
 281    )
 282   "Database of file tables for system libraries saved to disk.")
 283
 284
 285 (provide 'semanticdb-system)
 286
 287 ;;; semanticdb-system.el ends here