eproject.el

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;
   3 ;; eproject.el --- project workspaces for emacs
   4 ;;
   5 ;; Copyright (C) 2008,2009 grischka
   6 ;;
   7 ;; Author: grischka -- grischka@users.sourceforge.net
   8 ;; Created: 24 Jan 2008
   9 ;; Version: 0.3
  10 ;;
  11 ;; This program is free software, released under the GNU General
  12 ;; Public License (GPL, version 2). For details see:
  13 ;;
  14 ;;     http://www.fsf.org/licenses/gpl.html
  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 GNU
  19 ;; General Public License for more details.
  20 ;;
  21 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22
  23 ;; There is a global file (~/.emacs.d/eproject.lst)
  24 (defun prj-globalfile ()
  25   (expand-file-name "eproject.lst"
  26      (if (boundp 'user-emacs-directory) user-emacs-directory
  27        "~/.emacs.d/")
  28      ))
  29
  30 ;; with the list of all projects
  31 (defvar prj-list)
  32
  33 ;; and the project that was open in the last session (if any)
  34 (defvar prj-last-open nil)
  35
  36 ;; and the frame coords from last session
  37 (defvar prj-frame-pos nil)
  38
  39 ;; eproject version that created the config file
  40 (defvar prj-version nil)
  41
  42 ;; Here is a function to reset these
  43 (defun prj-init ()
  44   (setq prj-version nil)
  45   (setq prj-list nil)
  46   (setq prj-last-open nil)
  47   (setq prj-frame-pos nil)
  48   )
  49
  50 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  51 ;; Each project has a directory
  52
  53 (defvar prj-directory)
  54
  55 ;; with a configuration files in it
  56 (defvar prj-default-cfg "eproject.cfg")
  57
  58 ;; This file defines:
  59
  60 ;; the list of files
  61 (defvar prj-files)
  62
  63 ;; the current file
  64 (defvar prj-curfile)
  65
  66 ;; an alist of settings
  67 (defvar prj-config)
  68
  69 ;; a list of tools
  70 (defvar prj-tools)
  71
  72 ;; a list of utility functions (feature incomplete)
  73 (defvar prj-functions nil)
  74
  75 ;; directory to run commands, default to prj-directory
  76 (defvar prj-exec-directory)
  77
  78 ;; Here are some default tools for new projects,
  79 ;; (which you might want to adjust to your needs)
  80
  81 (defun prj-default-config ()
  82   (setq prj-tools (copy-tree '(
  83      ("Make"         "make" "f9")
  84      ("Clean"        "make clean" "C-f9")
  85      ("Run"          "echo run what" "f8")
  86      ("Stop"         "-e eproject-killtool" "C-f8")
  87      ("---")
  88      ("Configure"    "./configure")
  89      ("---")
  90      ("Explore Project" "nautilus --browser `pwd` &")
  91      ("XTerm In Project" "xterm &")
  92      )))
  93   )
  94
  95 ;; The current project
  96 (defvar prj-current)
  97
  98 ;; A list with generated functions for each tool
  99 (defvar prj-tools-fns)
 100
 101 ;; A list with files removed from the project
 102 (defvar prj-removed-files)
 103
 104 ;; Here is a function to reset/close the project
 105 (defun prj-reset ()
 106   (setq prj-version nil)
 107   (setq prj-current nil)
 108   (setq prj-directory nil)
 109   (setq prj-exec-directory nil)
 110   (setq prj-files nil)
 111   (setq prj-removed-files nil)
 112   (setq prj-curfile nil)
 113   (setq prj-config nil)
 114   (setq prj-tools nil)
 115   (setq prj-tools-fns nil)
 116   (prj-reset-functions)
 117   (prj-default-config)
 118   )
 119
 120 (defun prj-reset-functions ()
 121   (dolist (l prj-functions)
 122     (if (eq (car l) 'setq)
 123         (makunbound (cadr l))
 124       (fmakunbound (cadr l))
 125       ))
 126   (setq prj-functions nil)
 127   )
 128
 129 (defun prj-set-functions (s)
 130   (prj-reset-functions)
 131   (setq prj-functions s)
 132   (dolist (l s) (eval l))
 133   )
 134
 135 ;; Some more variables:
 136
 137 ;; the frame that exists on startup
 138 (defvar prj-initial-frame nil)
 139
 140 ;; this is put into minor-mode-alist
 141 (defvar eproject-mode t)
 142
 143 ;; where this file is in
 144 (defvar eproject-directory)
 145
 146 ;; eproject version that created the files
 147 (defvar eproject-version "0.3")
 148
 149 ;; Configuration UI
 150 (eval-and-compile
 151   (defun eproject-setup-toggle () (interactive))
 152   (defun eproject-setup-quit () (interactive))
 153   (defun prj-config-get-result (s))
 154   (defun prj-config-reset ())
 155   (defun prj-config-print ())
 156   (defun prj-config-parse ())
 157   )
 158
 159 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 160 ;; Small functions
 161
 162 (defun caddr (l) (car (cddr l)))
 163
 164 (defun prj-del-list (l e)
 165   (let ((a (assoc (car e) l)))
 166     (if a
 167         (delq a l)
 168       l)))
 169
 170 (defun prj-add-list (l e)
 171   (nconc (prj-del-list l e) (list e))
 172   )
 173
 174 (defun prj-next-file (l e)
 175   (and (setq e (assoc (car e) l))
 176        (cadr (memq e l))
 177        ))
 178
 179 (defun prj-prev-file (l e)
 180   (prj-next-file (reverse l) e)
 181   )
 182
 183  ; replace a closed file, either by the previous or the next.
 184 (defun prj-otherfile (l f)
 185   (or (prj-prev-file l f)
 186       (prj-next-file l f)
 187       ))
 188
 189 ;; make relative path, but only up to the second level of ..
 190 (defun prj-relative-path (f)
 191   (let ((r (file-relative-name f prj-directory)))
 192     (if (string-match "^\\.\\.[/\\]\\.\\.[/\\]\\.\\.[/\\]" r)
 193         f
 194       r
 195       )))
 196
 197 ;; friendly truncate filename
 198 (defun prj-shortname (s)
 199   (let ((l (length s)) (x 30) n)
 200     (cond ((>= x l) s)
 201           ((progn
 202              (setq x (- x 3))
 203              (setq n (length (file-name-nondirectory s)))
 204              (if (< n l) (setq n (1+ n)))
 205              (>= x n)
 206              )
 207            (concat (substring s 0 (- x n)) "..." (substring s (- n)))
 208            )
 209           ((= n l)
 210            (concat (substring s 0 x) "...")
 211            )
 212           (t
 213            (concat "..." (substring s (- n) (- (- x 3) n)) "...")
 214            ))))
 215
 216 (defun prj-settitle ()
 217   (modify-frame-parameters
 218    nil
 219    (list (cons 'title
 220                (and prj-current
 221                     (format "emacs - %s" (car prj-current))
 222                     )))))
 223
 224 (defun eproject-addon (f)
 225   (concat eproject-directory f)
 226   )
 227
 228 (defun prj-goto-line (n)
 229   (goto-char 1)
 230   (beginning-of-line n)
 231   )
 232
 233 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 234 ;; Write configuration to file
 235
 236 (defun prj-print-list (s fp)
 237   (let ((v (eval s)))
 238     (setq v (list 'setq s
 239       (if (and (atom v) (null (and (symbolp v) v)))
 240           v
 241           (list 'quote v)
 242           )))
 243     ;;(print v fp)
 244     (pp v fp) (princ "\n" fp)
 245     ))
 246
 247 (defun prj-create-file (filename)
 248   (let ((fp (generate-new-buffer filename)))
 249     (princ ";; -*- mode: Lisp; -*-\n\n" fp)
 250     fp))
 251
 252 (defun prj-close-file (fp)
 253   (with-current-buffer fp
 254     (condition-case nil
 255       (and t (write-region nil nil (buffer-name fp) nil 0))
 256       (error nil)
 257       ))
 258   (kill-buffer fp)
 259   )
 260
 261 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 262 ;; Load/Save global project list and initial frame sizes
 263
 264 (defun prj-loadlist ()
 265   (prj-init)
 266   (load (prj-globalfile) t t)
 267   (setq prj-version eproject-version)
 268   )
 269
 270 (defun prj-get-frame-pos (f)
 271   (mapcar
 272    (lambda (parm) (cons parm (frame-parameter f parm)))
 273    '(top left width height)
 274    ))
 275
 276 (defun prj-savelist ()
 277   (let ((g (prj-globalfile)) fp)
 278     (unless (file-exists-p g)
 279       (make-directory (file-name-directory g) t)
 280       )
 281     (setq prj-last-open (car prj-current))
 282     (when (frame-live-p prj-initial-frame)
 283       (setq prj-frame-pos (prj-get-frame-pos prj-initial-frame))
 284       )
 285     (setq fp (prj-create-file g))
 286     (when fp
 287       (prj-print-list 'prj-version fp)
 288       (prj-print-list 'prj-list fp)
 289       (prj-print-list 'prj-last-open fp)
 290       (prj-print-list 'prj-frame-pos fp)
 291       (prj-close-file fp)
 292       )))
 293
 294 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 295 ;; Load/Save local per-project configuration file
 296
 297 (defun prj-update-config ()
 298   (let ((d (prj-get-directory prj-current))
 299         (e (prj-getconfig "exec-root"))
 300         )
 301     (if e (setq d (expand-file-name e d)))
 302     (setq prj-exec-directory (file-name-as-directory d))
 303     ))
 304
 305 (defun prj-get-directory (a)
 306   (file-name-as-directory (expand-file-name (cadr a)))
 307   )
 308
 309 (defun prj-get-cfg ()
 310   (expand-file-name (or (caddr prj-current) prj-default-cfg) prj-directory)
 311   )
 312
 313 (defun prj-loadconfig (a)
 314   (let (lf e)
 315     (prj-reset)
 316     (setq prj-current a)
 317     (setq prj-directory (prj-get-directory a))
 318     (when (file-regular-p (setq lf (prj-get-cfg)))
 319       (load lf nil t)
 320       (setq prj-curfile
 321             (or (assoc prj-curfile prj-files)
 322                 (car prj-files)
 323                 ))
 324       )
 325     (if (setq e (prj-getconfig "project-name"))
 326         (setcar a e)
 327         (prj-setconfig "project-name" (car a))
 328         )
 329     (prj-update-config)
 330     (prj-set-functions prj-functions)
 331     (setq prj-version eproject-version)
 332     ))
 333
 334 (defun prj-saveconfig ()
 335   (when prj-current
 336     (let (w c b files)
 337       (prj-removehooks)
 338       (setq w (selected-window))
 339       (setq c (window-buffer w))
 340       (dolist (f prj-files)
 341         (cond ((setq b (get-buffer (car f)))
 342                (set-window-buffer w b t)
 343                (with-current-buffer b
 344                  (let ((s (line-number-at-pos (window-start w)))
 345                        (p (line-number-at-pos (window-point w)))
 346                        )
 347                    (push (list (car f) s p) files)
 348                    )))
 349               (t ;;(consp (cdr f))
 350                (push f files)
 351                )))
 352       (set-window-buffer w c t)
 353       (prj-addhooks)
 354       (let ((fp (prj-create-file (prj-get-cfg)))
 355             (prj-curfile (car prj-curfile))
 356             (prj-files (nreverse files))
 357             )
 358         (when fp
 359           (prj-print-list 'prj-version fp)
 360           (prj-print-list 'prj-config fp)
 361           (prj-print-list 'prj-tools fp)
 362           (prj-print-list 'prj-files fp)
 363           (prj-print-list 'prj-curfile fp)
 364           (prj-print-list 'prj-functions fp)
 365           (prj-close-file fp)
 366           ))
 367       )))
 368
 369 (defun prj-saveall ()
 370   (prj-saveconfig)
 371   (prj-savelist)
 372   )
 373
 374 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 375 ;; The core functions:  Open / Close / Add / Remove  Project
 376
 377 (defun eproject-open (a)
 378   "Open another project."
 379   (interactive
 380    (list
 381     (or (prj-config-get-result 'p)
 382         (completing-read "Open Project: " (mapcar 'car prj-list))
 383         )))
 384   (unless (consp a)
 385     (let ((b (assoc a prj-list)))
 386       (unless b
 387         (error "No such project: %s" a)
 388         )
 389       (setq a b)
 390       ))
 391   (setq a (or (car (member a prj-list)) a))
 392   (unless (eq a prj-current)
 393     (unless (file-directory-p (prj-get-directory a))
 394       (error "No such directory: %s" (cadr a))
 395       )
 396     (setq prj-list (cons a (delq a prj-list)))
 397     (eproject-close)
 398     (prj-loadconfig a)
 399     )
 400   (prj-addhooks)
 401   (prj-setup-all)
 402   (prj-isearch-setup)
 403   (cd prj-directory)
 404   (unless (prj-edit-file prj-curfile)
 405     (eproject-dired)
 406     ))
 407
 408 (defun eproject-close ()
 409   "Close the current project."
 410   (interactive)
 411   (when prj-current
 412     (prj-saveconfig)
 413     (prj-removehooks)
 414     (let (f)
 415       (unwind-protect
 416           (progn
 417             (save-some-buffers nil)
 418             (eproject-killbuffers t)
 419             (setq f t)
 420             )
 421         (or f (prj-addhooks))
 422         ))
 423     (prj-reset)
 424     (prj-config-reset)
 425     (prj-setup-all)
 426     (prj-isearch-setup)
 427     ))
 428
 429 (defun eproject-killbuffers (&optional from-project)
 430   "If called interactively kills all buffers that
 431 do not belong to  project files"
 432   (interactive)
 433   (let (a b)
 434     (dolist (f prj-files)
 435       (setq b (get-buffer (car f)))
 436       (if b
 437           (setq a (cons (list b) a))
 438           ))
 439     (dolist (b (buffer-list))
 440       (when (eq (consp (assoc b a)) from-project)
 441         (kill-buffer b)
 442         ))))
 443
 444 (defun eproject-add (dir &optional name cfg)
 445   "Add a new or existing project to the list."
 446   (interactive
 447    (let (d n f)
 448     (setq d (read-directory-name "Add project in directory: " prj-directory nil t))
 449     (setq n (file-name-nondirectory (directory-file-name d)))
 450     (setq n (read-string "Project name: " n))
 451     (setq f (read-string "Project file: " prj-default-cfg))
 452     (list d n f)
 453     ))
 454   (when dir
 455     (setq dir (directory-file-name dir))
 456     (setq name (file-name-nondirectory dir))
 457     (when (and cfg (string-equal cfg prj-default-cfg))
 458       (setq cfg nil)
 459       )
 460     (let ((a (if cfg (list name dir cfg) (list name dir))))
 461       (push a prj-list)
 462       (eproject-open a)
 463       )))
 464
 465 (defun eproject-remove (a)
 466   "Remove a project from the list."
 467   (interactive
 468    (list
 469     (or (prj-config-get-result 'p)
 470         (completing-read "Remove project: " (mapcar 'car prj-list))
 471         )))
 472   (unless (consp a)
 473     (let ((b (assoc a prj-list)))
 474       (unless b
 475         (error "No such project: %s" a)
 476         )
 477       (setq a b)
 478       ))
 479   (when (progn
 480           (beep)
 481           (prog1 (y-or-n-p (format "Remove \"%s\"? " (car a)))
 482             (message "")
 483             ))
 484     (setq prj-list (prj-del-list prj-list a))
 485     (prj-setup-all)
 486     ))
 487
 488 (defun eproject-save ()
 489   "Save the project configuration to file."
 490   (interactive)
 491   (prj-config-parse)
 492   (prj-config-print)
 493   (prj-saveall)
 494   )
 495
 496 (defun eproject-revert ()
 497   "Reload the project configuration from file."
 498   (interactive)
 499   (prj-loadlist)
 500   (if prj-current
 501       (prj-loadconfig prj-current)
 502     )
 503   (prj-setup-all)
 504   )
 505
 506 (defun eproject-addfile (f)
 507   "Add a file to the current project."
 508   (interactive
 509    (and prj-current
 510         (list
 511          (read-file-name "Add file to project: " nil nil t nil)
 512          )))
 513   (unless prj-current (error "No project open"))
 514   (let ((a (prj-insert-file f (prj-config-get-result 'f))))
 515     (unless (cdr a)
 516       (message "Added to project: %s" (car a))
 517       ))
 518   (prj-config-print)
 519   (prj-setmenu)
 520   )
 521
 522 (defun eproject-removefile (a)
 523   "Remove a file from the current project."
 524   (interactive (prj-get-existing-file-1 "Remove file from project: "))
 525   (setq a (prj-get-existing-file-2 a))
 526   (prj-remove-file a)
 527   )
 528
 529 (defun eproject-visitfile (a)
 530   "Visit a file from the current project."
 531   (interactive (prj-get-existing-file-1 "Visit file: "))
 532   (setq a (prj-get-existing-file-2 a))
 533   (prj-edit-file a)
 534    )
 535
 536 (defun prj-get-existing-file-1 (msg)
 537   (and prj-current
 538        (list
 539         (or (prj-config-get-result 'f)
 540             (completing-read msg (mapcar 'car prj-files))
 541             ))))
 542
 543 (defun prj-get-existing-file-2 (a)
 544    (unless prj-current (error "No project open"))
 545    (if (consp a)
 546        a
 547      (let ((b (assoc (prj-relative-path a) prj-files)))
 548        (unless b (error "No such file in project: %s" a))
 549        b
 550        )))
 551
 552 (defun eproject-help ()
 553   "Show the eproject README."
 554   (interactive)
 555   (view-file (eproject-addon "eproject.txt"))
 556   )
 557
 558 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 559 ;; Hook functions to track opening/closing files from emacs
 560
 561 (defun prj-addhooks ()
 562   (add-hook 'kill-buffer-hook 'prj-kill-buffer-hook)
 563   (add-hook 'find-file-hook 'prj-find-file-hook)
 564   (add-hook 'window-configuration-change-hook 'prj-wcc-hook)
 565   )
 566
 567 (defun prj-removehooks ()
 568   (remove-hook 'window-configuration-change-hook 'prj-wcc-hook)
 569   (remove-hook 'find-file-hook 'prj-find-file-hook)
 570   (remove-hook 'kill-buffer-hook 'prj-kill-buffer-hook)
 571   )
 572
 573 (defun prj-wcc-hook ()
 574   (let ((w (selected-window)) (b (window-buffer (selected-window))))
 575     ;;(message "wcc-hook: %s" (prin1-to-string (list w b)))
 576     (prj-register-buffer b)
 577     ))
 578
 579 (defun prj-find-file-hook ()
 580   (run-with-idle-timer
 581    0
 582    nil
 583    `(lambda () (prj-register-buffer ,(current-buffer)))
 584    ))
 585
 586 (defun prj-kill-buffer-hook ()
 587   (let ((b (current-buffer)) a)
 588     (if (setq a (rassq b prj-files))
 589         (prj-remove-file a t)
 590         (if (setq a (rassq b prj-removed-files))
 591             (setq prj-removed-files (delq a prj-removed-files))
 592           ))))
 593
 594 (defun prj-register-buffer (b)
 595   (let (f a)
 596     (setq f (buffer-file-name b))
 597     (when (and f t) ;;(not (string-match "^\\." (file-name-nondirectory f))))
 598       (setq a (rassq b prj-files))
 599       (unless a
 600         (setq a (prj-insert-file f nil t))
 601         (when a
 602           (unless (cdr a)
 603             (message "Added to project: %s" (car a))
 604             )
 605           (setcdr a b)
 606           (with-current-buffer b
 607             (rename-buffer (car a) t)
 608             )))
 609       (when (and a (null (eq a prj-curfile)))
 610         (setq prj-curfile a)
 611         (prj-setmenu)
 612         ))
 613     a))
 614
 615 (defun prj-insert-file (f &optional after on-the-fly)
 616   (let ((r (prj-relative-path f)) a m)
 617     (setq a (assoc r prj-files))
 618     (unless (or a (and on-the-fly (assoc r prj-removed-files)))
 619       (setq a (list r))
 620       (setq m (memq (or after prj-curfile) prj-files))
 621       (if m
 622           (setcdr m (cons a (cdr m)))
 623           (setq prj-files (prj-add-list prj-files a))
 624           )
 625       (setq prj-removed-files (prj-del-list prj-removed-files a))
 626       )
 627     a))
 628
 629 (defun prj-remove-file (a &optional on-the-fly)
 630   (let ((n (prj-otherfile prj-files a)) b)
 631     (setq prj-files (prj-del-list prj-files a))
 632     (when (eq prj-curfile a)
 633       (setq prj-curfile n)
 634       )
 635     (unless on-the-fly
 636         (setq prj-removed-files (prj-add-list prj-removed-files a))
 637         )
 638     (unless (prj-config-print)
 639       (prj-edit-file prj-curfile)
 640       )
 641     (prj-setmenu)
 642     (message "Removed from project: %s" (car a))
 643     ))
 644
 645 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 646 ;; Edit another file
 647
 648 (defun prj-find-file (a)
 649   (when a
 650     (let ((n (car a)) f b pos)
 651       (setq f (expand-file-name n prj-directory))
 652       (setq b (get-file-buffer f))
 653       (unless b
 654         (prj-removehooks)
 655         (setq b (find-file-noselect f))
 656         (prj-addhooks)
 657         (when b
 658           (with-current-buffer b
 659             (rename-buffer n t)
 660             )
 661           (setq pos (cdr a))
 662           ))
 663       (when b
 664         (setcdr a b)
 665         (cons b pos)
 666         ))))
 667
 668 (defun prj-edit-file (a)
 669   (let ((f (prj-find-file a)))
 670     (when f
 671       (eproject-setup-quit)
 672       (switch-to-buffer (car f))
 673       (prj-restore-edit-pos (cdr f) (selected-window))
 674       (prj-setmenu)
 675       )
 676     (setq prj-curfile a)
 677     ))
 678
 679 (defun prj-restore-edit-pos (pos w)
 680   (when (consp pos)
 681     (let ((top (car pos)) (line (cadr pos)))
 682       (when (and (numberp top) (numberp line))
 683         (prj-goto-line top)
 684         (set-window-start w (point))
 685         (prj-goto-line line)
 686         ))))
 687
 688 (defun prj-select-window (w)
 689   (let (focus-follows-mouse)
 690     (select-window w)
 691     (select-frame-set-input-focus (window-frame w))
 692     ))
 693
 694 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 695 ;; choose next/previous file
 696
 697 (defun eproject-nextfile ()
 698   "Switch to the next file that belongs to the current project."
 699   (interactive)
 700   (prj-switch-file 'prj-next-file 'next-buffer)
 701   )
 702
 703 (defun eproject-prevfile ()
 704   "Switch to the previous file that belongs to the current project."
 705   (interactive)
 706   (prj-switch-file 'prj-prev-file 'previous-buffer)
 707   )
 708
 709 (defun prj-switch-file (fn1 fn2)
 710   (let ((a (rassoc (current-buffer) prj-files)))
 711     (cond (a
 712            (prj-edit-file (or (funcall fn1 prj-files a) a))
 713            )
 714           (prj-curfile
 715            (prj-edit-file prj-curfile)
 716            )
 717           (t
 718            (funcall fn2)
 719            ))))
 720
 721 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 722 ;; Set key shortcuts
 723
 724 (defun prj-setkeys ()
 725   (let ((f (consp prj-current))
 726         (a (assoc 'eproject-mode minor-mode-map-alist))
 727         (map (make-sparse-keymap))
 728         )
 729     (if a
 730         (setcdr a map)
 731         (push (cons 'eproject-mode map) minor-mode-map-alist)
 732         )
 733     (when f
 734       (define-key map [M-right] 'eproject-nextfile)
 735       (define-key map [M-left] 'eproject-prevfile)
 736       (define-key map [C-f5] 'eproject-dired)
 737       (let ((n 0) fn s)
 738         (dolist (a prj-tools)
 739           (unless (setq fn (nth n prj-tools-fns))
 740             (setq fn (list 'lambda))
 741             (setq prj-tools-fns (nconc prj-tools-fns (list fn)))
 742             )
 743           (setcdr fn `(() (interactive) (prj-run-tool ',a)))
 744           (setq n (1+ n))
 745           (when (setq s (caddr a))
 746             (define-key map (prj-parse-key s) (and f fn))
 747             ))))
 748     (define-key map [f5] 'eproject-setup-toggle)
 749     ))
 750
 751 (defun prj-parse-key (s)
 752   (read
 753    (if (string-match "[a-z][a-z0-9]+$" s)
 754        (concat "[" s "]")
 755        (concat "\"\\" s "\""))))
 756
 757 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 758 ;; Set menus
 759
 760 (defun prj-list-sorted ()
 761   (sort (append prj-list nil)
 762         '(lambda (a b) (string-lessp (car a) (car b)))
 763         ))
 764
 765 (defun prj-setmenu ()
 766   (let ((f (consp prj-current)) m1 m2 m3)
 767
 768     (setq m1
 769           `(("Open" open ,@(prj-menulist-maker prj-list prj-current 'prj-menu-open))
 770             ("Add/Remove" other
 771              ("Add ..." "Add new or existing project to the list" . eproject-add)
 772              ("Remove ..." "Remove project from the list" . eproject-remove)
 773              ,@(and f '(("Close" "Close current project" . eproject-close)))
 774              ("--")
 775              ("Setup" "Enter the project setup area." . eproject-setup-toggle)
 776              ("Help" "View eproject.txt" . eproject-help)
 777              )
 778             ))
 779     (when f
 780       (nconc m1 (cons '("--") (prj-menulist-maker prj-tools nil prj-tools-fns)))
 781       (setq m2
 782             `(("Dired" "Browse project directory in Dired - Use 'a' to add file(s) to the project" . eproject-dired)
 783               ("--")
 784               ,@(prj-menulist-maker prj-files prj-curfile 'prj-menu-edit)
 785               )))
 786
 787     (prj-menu-maker
 788      global-map
 789      `((buffer "Project" project ,@m1)
 790        (file "List" list ,@m2)
 791        )
 792      '(menu-bar)
 793      )))
 794
 795 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 796
 797 (defun prj-menu-edit ()
 798   (interactive)
 799   (let ((a (nth last-command-event prj-files)))
 800     (if a (prj-edit-file a))
 801     ))
 802
 803 (defun prj-menu-open ()
 804   (interactive)
 805   (let ((a (nth last-command-event prj-list)))
 806     (if a (eproject-open (car a)))
 807     ))
 808
 809 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 810
 811 (defun prj-menu-maker (map l v)
 812   (let ((e (list nil)))
 813     (setq v (append v e))
 814     (dolist (k (reverse l))
 815       (let (s a)
 816         (when (symbolp (car k))
 817           (setq a (pop k))
 818           )
 819         (cond
 820          ((numberp (car k))
 821           (setcar e (pop k))
 822           )
 823          ((and (consp (cdr k)) (symbolp (cadr k)))
 824           (setcar e (cadr k))
 825           (setq s (cddr k))
 826           (setq k (and s (cons (car k) (make-sparse-keymap (car k)))))
 827           )
 828          (t
 829           (setcar e (intern (downcase (car k))))
 830           ))
 831         (if a
 832             (define-key-after map (vconcat v) k a)
 833             (define-key map (vconcat v) k)
 834             )
 835         (if s (prj-menu-maker map s v))
 836         ))))
 837
 838 (defun prj-copy-head (l n)
 839   (let (r)
 840     (while (and l (> n 0))
 841       (push (pop l) r)
 842       (setq n (1- n))
 843       )
 844     (nreverse r)
 845     ))
 846
 847 (defun prj-split-list (l n)
 848   (let (r)
 849     (while l
 850       (push (prj-copy-head l n) r)
 851       (setq l (nthcdr n l))
 852       )
 853     (nreverse r)
 854     ))
 855
 856 (defun prj-menulist-maker (l act fns)
 857   (let (r (w 30) s (m 0) (n 0) k)
 858     (cond
 859      ((< (length l) w)
 860       (prj-menulist-maker-1 (list l fns n) act)
 861       )
 862      (t
 863       ;; menu too long; split into submenus
 864       (setq s (prj-split-list l w))
 865       (setq k (prj-menulist-maker-1 (list (append (pop s) '(("--"))) fns n) act))
 866       (setq r (nreverse k))
 867       (dolist (l s)
 868         (when (consp fns)
 869           (setq fns (nthcdr w fns))
 870           )
 871         (setq n (+ n w))
 872         (setq k (prj-menulist-maker-1 (list l fns n) act))
 873         (push (cons (concat (prj-shortname (caar l)) " ...")
 874                     (cons (intern (format "m_%d" (setq m (1+ m))))
 875                           k)) r)
 876         )
 877       (nreverse r)
 878       ))))
 879
 880 (defun prj-menulist-maker-1 (l act)
 881   (let (r e f s i n a)
 882     (while (car l)
 883       (setq a (caar l))
 884       (setcar l (cdar l))
 885       (setq n (caddr l))
 886       (setcar (cddr l) (1+ n))
 887       (setq f (if (consp (cadr l))
 888                   (prog1 (car (cadr l)) (setcar (cdr l) (cdr (cadr l))))
 889                   (cadr l)))
 890
 891       (setq i (car a))
 892       (unless (string-match "^ *#" i)
 893         (setq s (if (and (consp (cdr a)) (stringp (cadr a))) (cadr a) i))
 894         (cond ((equal ">" i)
 895                (setq e (cons s (cons (intern s) (prj-menulist-maker-1 l act))))
 896                (setq r (cons e r))
 897                )
 898               ((equal "<" i)
 899                (setq l nil)
 900                )
 901               (t
 902                (setq i (prj-shortname i))
 903                (setq e (cons n (if (eq a act)
 904                                    `(menu-item ,i ,f :button (:toggle . t) :help ,s)
 905                                  (cons i (cons s f)))))
 906                (setq r (cons e r))
 907                )))
 908       )
 909     (nreverse r)
 910     ))
 911
 912 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 913 ;; Run make and other commands
 914
 915 (defun prj-setup-tool-window ()
 916   (let ((bn "*compilation*") w h b c f)
 917     (unless (get-buffer-window bn t)
 918       (setq b (get-buffer-create bn))
 919       (setq f (frame-list))
 920       (cond ((cdr f)
 921              (setq w (frame-first-window (car f)))
 922              (delete-other-windows w)
 923              )
 924             (t
 925              (setq h (/ (* 70 (frame-height)) 100))
 926              (delete-other-windows w)
 927              (setq w (split-window w h))
 928              ))
 929       (set-window-buffer w b)
 930       )))
 931
 932 (defun prj-run (cmd)
 933   (let (dir)
 934     (when (string-match "^-in +\\([^[:space:]]+\\) +" cmd)
 935       (setq dir (match-string-no-properties 1 cmd))
 936       (setq cmd (substring cmd (match-end 0)))
 937       )
 938     (when prj-exec-directory
 939       (setq dir (expand-file-name (or dir ".") prj-exec-directory))
 940       )
 941     (if dir (cd dir))
 942     (cond ((string-match "^-e +" cmd)
 943            (setq cmd (read (substring cmd (match-end 0))))
 944            (unless (commandp cmd)
 945              (setq cmd `(lambda () (interactive) ,cmd))
 946              )
 947            (command-execute cmd)
 948            )
 949           ((string-match "\\(.+\\)& *$" cmd)
 950            (start-process-shell-command "eproject-async" nil (match-string 1 cmd))
 951            (message (match-string 1 cmd))
 952            )
 953           (t
 954            (unless (or (fboundp 'ecb-activate) (fboundp 'ewm-init))
 955              (prj-setup-tool-window)
 956              )
 957            (let ((display-buffer-reuse-frames t) (f (selected-frame)))
 958              (compile cmd)
 959              (select-frame-set-input-focus f)
 960              )))))
 961
 962 (defun prj-run-tool (a)
 963   (unless (string-match "^--+$" (car a))
 964     (prj-run (or (cadr a) (car a)))
 965     ))
 966
 967 (defun eproject-killtool ()
 968   (interactive)
 969   (let ((bn "*compilation*") w0 w1)
 970     (when (setq w1 (get-buffer-window bn t))
 971       (when (fboundp 'kill-compilation)
 972         (setq w0 (selected-window))
 973         (select-window w1)
 974         (kill-compilation)
 975         (select-window w0)
 976         ))))
 977
 978 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 979 ;; run grep on project files
 980
 981 (defun eproject-grep (command-args)
 982   "Run the grep command on all the project files."
 983   (interactive
 984    (progn
 985      (require 'grep)
 986      (grep-compute-defaults)
 987      (let ((default (grep-default-command)))
 988        (list (read-from-minibuffer
 989               "Run grep on project files: "
 990               (if current-prefix-arg default grep-command)
 991               nil
 992               nil
 993               'grep-history
 994               (if current-prefix-arg nil default)
 995               )))))
 996     (let ((default-directory prj-directory))
 997     (dolist (f (mapcar 'car prj-files))
 998       (setq command-args (concat command-args " " f))
 999       )
1000     (grep command-args)
1001     ))
1002
1003 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1004 ;; add files to the project with dired
1005
1006 (require 'dired)
1007
1008 (defun prj-dired-addfiles ()
1009   (interactive)
1010   (when prj-current
1011     (let ((n 0) a)
1012       (dolist (f (dired-get-marked-files))
1013         (setq a (prj-insert-file f))
1014         (unless (cdr a)
1015           (setq n (1+ n))
1016           (setq prj-curfile a)
1017           ))
1018       (message "Added to project: %d file(s)" n)
1019       (prj-setmenu)
1020       )))
1021
1022 (defun prj-dired-run ()
1023   (interactive)
1024   (let ((f (dired-get-marked-files)) c)
1025     (and (setq c (pop f))
1026          (null f)
1027          (let ((prj-directory (file-name-directory c)))
1028            (prj-run c)))))
1029
1030 (defun eproject-dired ()
1031   "Start a dired window with the project directory."
1032   (interactive)
1033   (when prj-directory
1034     (eproject-setup-quit)
1035     ;;(message "Use 'a' to add marked or single files to the project.")
1036     (dired prj-directory)
1037     (let ((map dired-mode-map))
1038       (define-key map [mouse-2] 'dired-find-file)
1039       (define-key map "a" 'prj-dired-addfiles)
1040       (define-key map "r" 'prj-dired-run)
1041       (define-key map [menu-bar operate command] '("Add to Project"
1042         "Add current or marked file(s) to project" . prj-dired-addfiles))
1043       )))
1044
1045 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1046
1047 (defun prj-setup-all ()
1048   (prj-setkeys)
1049   (prj-setmenu)
1050   (prj-settitle)
1051   (prj-config-print)
1052 )
1053
1054 (defun prj-getconfig (n)
1055   (let ((a (cdr (assoc n prj-config))))
1056     (and (stringp a) a)
1057     ))
1058
1059 (defun prj-setconfig (n v)
1060   (let ((a (assoc n prj-config)))
1061     (unless a
1062       (setq a (list n))
1063       (setq prj-config (nconc prj-config (list a)))
1064       )
1065     (setcdr a v)
1066     ))
1067
1068 (defun prj-on-kill ()
1069   (prj-saveall)
1070 )
1071
1072 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1073 ;; isearch in all project files
1074
1075 (defun prj-isearch-function (b wrap)
1076   (let (a d)
1077     (or b (setq b (current-buffer)))
1078     (cond (wrap
1079            (if isearch-forward
1080                (setq a (car prj-files))
1081                (setq a (car (last prj-files)))
1082                ))
1083           ((setq a (rassoc b prj-files))
1084            (if isearch-forward
1085                (setq a (prj-next-file prj-files a))
1086                (setq a (prj-prev-file prj-files a))
1087                )
1088             ))
1089     (when a
1090       (if (buffer-live-p (cdr a))
1091           (setq d (cdr a))
1092           (setq d (car (prj-find-file a)))
1093           ))
1094     ;; (print `(prj-isearch (wrap . ,wrap) ,b ,d) (get-buffer "*Messages*"))
1095     d
1096     ))
1097
1098 (defun prj-isearch-setup ()
1099   (cond (prj-current
1100          (setq multi-isearch-next-buffer-function 'prj-isearch-function)
1101          (setq multi-isearch-pause 'initial)
1102          (add-hook 'isearch-mode-hook 'multi-isearch-setup)
1103          )
1104         (t
1105          (remove-hook 'isearch-mode-hook 'multi-isearch-setup)
1106          )))
1107
1108 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1109 ;; Initialize
1110
1111 (defun prj-startup-delayed ()
1112   ;; load UI support
1113   (load (eproject-addon "eproject-config") nil t)
1114
1115   ;; When no projects are specified yet, load the eproject project itself.
1116   (unless prj-list
1117     (load (eproject-addon prj-default-cfg))
1118     )
1119
1120   ;; no project so far
1121   (prj-reset)
1122   (prj-setup-all)
1123   (add-hook 'kill-emacs-hook 'prj-on-kill)
1124
1125   ;; inhibit open last project when a file was on the commandline
1126   (unless (buffer-file-name (window-buffer))
1127     (when prj-last-open
1128
1129       ;; open last project
1130       (eproject-open prj-last-open)
1131
1132       ;; restore frame position
1133       (unless (fboundp 'ewm-init)
1134         (when (and prj-frame-pos prj-initial-frame)
1135           (modify-frame-parameters prj-initial-frame prj-frame-pos)
1136           ;; emacs bug: when it's too busy it doesn't set frames correctly.
1137           (sit-for 0.2)
1138           ))))
1139
1140   (when (fboundp 'ecb-activate)
1141     (ecb-activate)
1142     )
1143   )
1144
1145 (defun prj-command-line-switch (option)
1146   (setq prj-last-open (pop argv))
1147   (setq inhibit-startup-screen t)
1148   )
1149
1150 (defun eproject-startup ()
1151   ;; where is this file
1152   (if load-file-name
1153       (setq eproject-directory (file-name-directory load-file-name)))
1154   (if (boundp 'prj-list)
1155     (progn
1156       (load (eproject-addon "eproject-config"))
1157       (prj-setup-all))
1158     (progn
1159       (prj-loadlist)
1160       (when prj-last-open (setq inhibit-startup-screen t))
1161       (when (display-graphic-p) (setq prj-initial-frame (selected-frame)))
1162       (push '("project" . prj-command-line-switch) command-switch-alist)
1163       (run-with-idle-timer 0.1 nil 'prj-startup-delayed)
1164       )))
1165
1166 ;;;###autoload(require 'eproject)
1167 (provide 'eproject)
1168 (eproject-startup)
1169
1170 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1171 ;; eproject.el ends here