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