eproject.el

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