extensions/sln-mode.el

   1 ;;; sln-mode.el --- Create a project-buffer using sln file
   2 ;;
   3 ;; Author:      Cedric Lallain <kandjar76@hotmail.com>
   4 ;; Version:     1.02
   5 ;; Keywords:    project buffer msvc sln vcproj viewer
   6 ;; Description: SLN File Project Viewer
   7 ;; Tested with: GNU Emacs 22.x and GNU Emacs 23.x
   8 ;;
   9 ;; This file is *NOT* part of GNU Emacs.
  10 ;;
  11 ;;    This program 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 of the License, or
  14 ;;    (at your option) any later version.
  15 ;;
  16 ;;    This program 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 this program; if not, write to the Free Software
  23 ;;    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  24 ;;
  25
  26
  27 ;;; Commentary:
  28 ;;
  29
  30 ;; This is an add-on library for project-buffer-mode
  31 ;;
  32 ;; This library provides a function to create a project-buffer
  33 ;; extracting the project information from a SLN file.
  34 ;;
  35 ;; To install it: just add the following lines to your init file:
  36 ;;   (autoload 'find-sln "sln-mode")
  37 ;;
  38 ;; find-sln is the command to execute to open a 'sln project'.
  39 ;;
  40 ;; Then check the project-buffer-mode for more documentation about
  41 ;; this mode.
  42 ;;
  43
  44 ;; Note about the build/clean/run/debug actions:
  45 ;;
  46 ;; The command line are different between a 2005 and a 2008 project;
  47 ;; by default it will use the 2005 configuration mode; use the prefix
  48 ;; argument to switch to the 2008 mode.
  49 ;;
  50 ;; -------
  51
  52 ;; Extra note:
  53 ;;
  54 ;; It doesn't currently support modifying the SLN file. It's currently
  55 ;; just a 'viewer'.  Note that it doens't have to stay that way if
  56 ;; people really need this feature. ;-)
  57 ;;
  58 ;; However it is possible to save the project as project-buffer
  59 ;; project files and reload it from there.
  60 ;;
  61 ;; -------
  62
  63
  64 ;;; History:
  65 ;;
  66 ;; v1.00: First official release.
  67 ;; v1.01: Register the project local variable in `project-buffer-locals-to-save'
  68 ;; v1.02: Ask confirmation before cleaning the project.
  69 ;;        Added refresh handler which reload the sln-file or the
  70 ;;        vcproj of the current project.
  71
  72
  73 (require 'cl)
  74 (require 'project-buffer-mode)
  75
  76
  77 ;;; Code:
  78
  79
  80 ;;
  81 ;; Customize data:
  82 ;;
  83
  84 (defgroup sln-mode nil
  85   "Customize the sln-mode library.")
  86
  87
  88 (defcustom sln-mode-devenv-2005 "Devenv"
  89   "Path to Devenv 2005."
  90   :type 'string
  91   :group 'sln-mode
  92   )
  93
  94 (defcustom sln-mode-devenv-2008 "Devenv"
  95   "Path to Devenv 2008."
  96   :type 'string
  97   :group 'sln-mode
  98   )
  99
 100 ;;
 101 ;; Helper function:
 102 ;;
 103
 104 (defvar sln-mode-solution-name nil
 105   "Local variable to store the solution name.")
 106
 107
 108 (defun vcproj-extract-platforms (current-block)
 109   "Extract a list of platform from CURRENT-BLOCK."
 110   (unless (eq (car current-block) 'Platforms) (error "Expected a list like '(Platforms ...)"))
 111   (let ((data (cdddr current-block))
 112         cur ret)
 113     (while data
 114       (setq cur (pop data))
 115       (when (listp cur)
 116         (unless (eq (car cur) 'Platform) (error "Unknown id: '%S' expected 'Platform" (car cur)))
 117         (unless (eq (caaadr cur) 'Name)   (error "Unknown id: '%S' expected 'Name" (car cur)))
 118         (setq ret (cons (cdaadr cur) ret))))
 119     (reverse ret)))
 120
 121
 122 (defun vcproj-extract-configurations (current-block)
 123   "Extract a list of configuration from CURRENT-BLOCK."
 124   (unless (eq (car current-block) 'Configurations) (error "Expected a list like '(Configurations ...)"))
 125   (let ((data (cdddr current-block))
 126         cur ret)
 127     (while data
 128       (setq cur (pop data))
 129       (when (listp cur)
 130         (unless (eq (car cur) 'Configuration) (error "Unknown id: '%S' expected 'Configuration" (car cur)))
 131         (let ((search-list (cadr cur))
 132               name)
 133           (while (and search-list (not name))
 134             (let ((item (pop search-list)))
 135               (setq name (and (eq (car item) 'Name) (cdr item)))))
 136           (unless name (error "Unknown configuration name!"))
 137           (setq ret (cons (car (split-string name "|")) ret)))))
 138     (reverse ret)))
 139
 140
 141 (defun vcproj-extract-file(current-item)
 142   "Extract the relative path of the current file contain in CURRENT-ITEM"
 143   (unless (eq (car current-item) 'File) (error "Expected a list like '(File ...)"))
 144   (let ((data (cadr current-item))
 145         file)
 146     (while (and data (not file))
 147       (let ((cur (pop data)))
 148         (setq file (and (eq (car cur) 'RelativePath) (cdr cur)))))
 149     file))
 150
 151
 152 (defun vcproj-extract-filter-name(current-item)
 153   "Extract the filter name of the CURRENT-ITEM"
 154   (unless (eq (car current-item) 'Filter) (error "Expected a list like '(Filter ...)"))
 155   (let ((data (cadr current-item))
 156         filter)
 157     (while (and data (not filter))
 158       (let ((cur (pop data)))
 159         (setq filter (and (eq (car cur) 'Name) (cdr cur)))))
 160     filter))
 161
 162
 163 (defun vcproj-extract-filter-list(current-item)
 164   "Extract the files/filter list attach to the current filter in CURRENT-ITEM"
 165     (unless (eq (car current-item) 'Filter) (error "Expected a list like '(Filter ...)"))
 166   (cddr current-item))
 167
 168
 169 (defun vcproj-convert-file-list(file-list)
 170   "Convert FILE-LIST from a list '((\"virt-subfolder\" \"virt-subfolder\"...) \"full-path\") to a list '(\"virtual-folder\" \"full-path\")"
 171   (let (ret)
 172     (while file-list
 173       (let* ((node (pop file-list))
 174              (vnode (car node))
 175              (fullpath (replace-regexp-in-string "\\\\" "/" (cdr node)))
 176              (file (file-name-nondirectory fullpath))
 177              (virt-folder (if vnode "/" "")))
 178         (while vnode
 179           (let ((item (pop vnode)))
 180             (setq virt-folder (concat item virt-folder))))
 181         (push (cons (concat virt-folder file) fullpath) ret)))
 182     ret))
 183
 184
 185 (defun vcproj-extract-files(current-block)
 186   "Extract a list of files from CURRENT-BLOCK"
 187   (unless (eq (car current-block) 'Files) (error "Expected a list like '(Files ...)"))
 188   (let ((data (cdddr current-block))
 189         cur ret stack folder)
 190     (push data stack)
 191     (while stack
 192       (let ((node (pop stack)))
 193         (pop folder)
 194         (while node
 195           (let ((item (pop node)))
 196             (when (listp item)
 197               (cond ((eq (car item) 'Filter)
 198                      (push node stack)
 199                      (push (vcproj-extract-filter-name item) folder)
 200                      (setq node (vcproj-extract-filter-list item)))
 201                     ((eq (car item) 'File)
 202                      (push (cons folder (vcproj-extract-file item)) ret))
 203                     (t (error "Unknown data - id: %S" (car item)))))))))
 204     (vcproj-convert-file-list ret)))
 205
 206
 207
 208 (defun vcproj-extract-data(vcproj-file)
 209   "Extract files and directory from VCPROJ-FILE"
 210   (save-excursion
 211     (let* ((xml-tags (with-temp-buffer
 212                        (insert-file vcproj-file)
 213                        (xml-parse-region (point-min) (point-max))))
 214            (vs-data (car xml-tags))
 215            (vs-tags  (and (eq (car vs-data) 'VisualStudioProject)
 216                           (cdddr vs-data)))
 217            ;;
 218            vc-platforms
 219            vc-configurations
 220            vc-files
 221            )
 222       ;;
 223       (while vs-tags
 224         (let ((cur-block (pop vs-tags)))
 225           (when (listp cur-block)
 226             (let ((block-tag (car cur-block)))
 227               (cond ((eq block-tag 'Platforms)
 228                      (setq vc-platforms (append (vcproj-extract-platforms cur-block) vc-platforms)))
 229                     ((eq block-tag 'ToolFiles))     ; Currently ignored
 230                     ((eq block-tag 'Configurations)
 231                      (setq vc-configurations (append (vcproj-extract-configurations cur-block) vc-configurations)))
 232                     ((eq block-tag 'References))    ; Currently ignored
 233                     ((eq block-tag 'Files)
 234                      (setq vc-files (append (vcproj-extract-files cur-block) vc-files)))
 235                     ((eq block-tag 'Globals))       ; Currently ignored
 236                     (t (error (format "Unknown block tag: %S" block-tag))))
 237             ))))
 238       (list vc-platforms vc-configurations vc-files))))
 239
 240
 241 (defun vcproj-update-file-folders(vc-files folder)
 242   "Update the folder of each files in VC-FILES adding FOLDER in front of them"
 243   (mapcar '(lambda (item)
 244              (cons (car item)
 245                    (if (file-name-absolute-p (cdr item))
 246                        (cdr item)
 247                        (let ((rela-path (file-relative-name (expand-file-name (concat folder (cdr item)))))
 248                              (full-path (abbreviate-file-name (expand-file-name (concat folder (cdr item))))))
 249                          (if (> (length rela-path) (length full-path))
 250                              full-path
 251                              rela-path)))))
 252           vc-files))
 253
 254
 255 (defun sln-extract-projects(sln-file)
 256   "Extract projects from the SLN file"
 257   (save-excursion
 258     (with-temp-buffer
 259       (insert-file sln-file)
 260       (goto-char (point-min))
 261       (let ((result nil))
 262         (while (re-search-forward "Project(\"{[-A-Z0-9]+}\")[   ]+=[    ]+\"\\([^\"]+\\)\"[     ]*,[    ]+\"\\([^\"]+\\)\""
 263                                   (point-max)  t)
 264           (add-to-list 'result (cons (match-string-no-properties 1) (replace-regexp-in-string "\\\\" "/" (match-string-no-properties 2))) t))
 265         result))))
 266
 267 (defun sln-file-p (filename)
 268   "Check if FILENAME is a sln file."
 269   (or
 270    (null (file-name-extension filename))
 271    (string= (file-name-extension filename) "sln")))
 272
 273
 274 (defun sln-action-handler-2005(action project-name project-path platform configuration)
 275   "Project-Buffer action handler."
 276   (let ((sln-cmd (cond ((eq action 'build) "Build")
 277                        ((eq action 'clean) "Clean")
 278                        ((eq action 'run)   "RunExit")
 279                        ((eq action 'debug) "DebugExe"))))
 280     (when (or (not (eq action 'clean))
 281               (funcall project-buffer-confirm-function (format "Clean the project %s " project-name)))
 282       (compile
 283        (concat sln-mode-devenv-2005 " \"" sln-mode-solution-name "\" /" sln-cmd " \""  (concat configuration "|" platform) "\" /project \"" project-path "\"")))))
 284
 285 (defun sln-action-handler-2008(action project-name project-path platform configuration)
 286   "Project-Buffer action handler."
 287   (let* ((prj-str (concat "/Project \"" project-name "\" "))
 288          (cfg-str (concat "\"" configuration "|" platform "\" "))
 289          (sln-cmd (cond ((eq action 'build) (concat "/Build " cfg-str))
 290                         ((eq action 'clean) (concat "/Clean " cfg-str))
 291                         ((eq action 'run)   (concat "/ProjectConfig " cfg-str ))
 292                         ((eq action 'debug) (concat "/ProjectConfig " cfg-str )))))
 293     (when (or (not (eq action 'clean))
 294               (funcall project-buffer-confirm-function (format "Clean the project %s " project-name)))
 295       (compile
 296        (concat sln-mode-devenv-2008 " \"" sln-mode-solution-name "\" "
 297                prj-str sln-cmd)))))
 298
 299
 300 (defun sln-add-vcproj-project(project-name vcproj-file)
 301   "Add a new project named PROJECT-NAME to the project bufffer,
 302 and use the content of VCPROJ-FILE to populate it."
 303   (let* ((project-dir (file-name-directory vcproj-file))
 304          (project-data (and (file-exists-p vcproj-file)
 305                             (vcproj-extract-data vcproj-file)))
 306          (platforms (car project-data))
 307          (configurations (cadr project-data)))
 308     ;; Create a project node / update its platform and build configuration...
 309     (project-buffer-insert project-name 'project vcproj-file project-name)
 310     (project-buffer-set-project-platforms project-name platforms)
 311     (project-buffer-set-project-build-configurations project-name configurations)
 312     (when project-data
 313       (let ((files (vcproj-update-file-folders (caddr project-data) project-dir)))
 314         (while files
 315           (let ((file (pop files)))
 316             ;; then insert each project file into the buffer
 317             (project-buffer-insert (car file) 'file (cdr file) project-name)))))))
 318
 319
 320 (defun sln-refresh-handler(project-list content)
 321   "Refresh handler.
 322 Base on CONTENT, it will either reload the sln file and recreate
 323 the projects; or just refresh the selected projects."
 324   (when (and project-list
 325              (funcall project-buffer-confirm-function
 326                       (if (eq content 'all)
 327                           (format "Reload %s " sln-mode-solution-name)
 328                           (format "Reload %s " (project-buffer-get-project-path (car project-list))))))
 329     (if (and (eq content 'all)
 330              (file-exists-p sln-mode-solution-name))
 331         ;; Clear the whole buffer and recreate each projects:
 332         (let ((sln-projects (sln-extract-projects sln-mode-solution-name)))
 333           (project-buffer-erase-all project-buffer-status)
 334           (while sln-projects
 335             (let ((current (pop sln-projects)))
 336               (sln-add-vcproj-project (car current) (cdr current)))))
 337         ;; Delete the specified projects and recreate them:
 338         (while project-list
 339           (let* ((project-name (pop project-list))
 340                  (vcproj-file  (project-buffer-get-project-path project-name)))
 341             (when (file-exists-p vcproj-file)
 342               (project-buffer-delete-project project-name)
 343               (sln-add-vcproj-project project-name vcproj-file)))))))
 344
 345
 346 (defun make-sln-project-buffer(sln-file &optional using2005)
 347   "Create a project buffer interpreting SLN-FILE to populate it."
 348   (let ((buffer (generate-new-buffer (concat "ms:" (file-name-nondirectory sln-file))))
 349         (sln-projects (sln-extract-projects sln-file)) ; list of proj-nane / project file
 350         )
 351     (switch-to-buffer buffer)
 352     (with-current-buffer buffer
 353       ;; Make sure the buffer path match the project's path
 354       (cd (file-name-directory sln-file))
 355       ;; Turn on the project-buffer-mode
 356       (project-buffer-mode)
 357       (make-local-variable 'sln-mode-solution-name)
 358       (add-to-list 'project-buffer-locals-to-save 'sln-mode-solution-name)
 359       (setq sln-mode-solution-name (file-name-nondirectory sln-file))
 360       (if using2005
 361           (add-hook 'project-buffer-action-hook 'sln-action-handler-2005 nil t)
 362           (add-hook 'project-buffer-action-hook 'sln-action-handler-2008 nil t))
 363       (add-hook 'project-buffer-refresh-hook 'sln-refresh-handler)
 364       ;;
 365       (while sln-projects
 366         ;; For every project reference in the SLN file,
 367         (let ((current (pop sln-projects)))
 368           (sln-add-vcproj-project (car current) (cdr current)))
 369         ))))
 370
 371
 372 ;;
 373 ;; Interactive command:
 374 ;;
 375
 376 ;;;###autoload
 377 (defun find-sln(solution-name &optional using2005)
 378   "Open an sln file and create a project buffer using the data in it."
 379   (interactive
 380    (list (read-file-name "SLN file: " nil nil t nil 'sln-file-p)
 381          current-prefix-arg))
 382   (when (and solution-name
 383              (> (length solution-name) 0))
 384     (make-sln-project-buffer solution-name using2005)))
 385
 386
 387 ;;
 388
 389 (provide 'sln-mode)
 390
 391 ;;; sln-mode.el ends here