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 (defun prj-goto-line (n)
 239   (goto-char 1)
 240   (beginning-of-line n)
 241   )
 242
 243 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 244 ;; Write configuration to file
 245
 246 (defun prj-print-list (s fp)
 247   (let ((v (eval s)))
 248     (setq v (list 'setq s
 249       (if (and (atom v) (null (and (symbolp v) v)))
 250           v
 251           (list 'quote v)
 252           )))
 253     ;;(print v fp)
 254     (pp v fp) (princ "\n" fp)
 255     ))
 256
 257 (defun prj-create-file (filename)
 258   (let ((fp (generate-new-buffer filename)))
 259     (princ ";; -*- mode: Lisp; -*-\n\n" fp)
 260     fp))
 261
 262 (defun prj-close-file (fp)
 263   (with-current-buffer fp
 264     (condition-case nil
 265       (write-region 1 (point-max) (buffer-name fp) nil 0)
 266       (error nil)
 267       ))
 268   (kill-buffer fp)
 269   )
 270
 271 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 272 ;; Load/Save global project list and initial frame sizes
 273
 274 (defun prj-loadlist ()
 275   (prj-init)
 276   (load (prj-globalfile) t t)
 277   (setq prj-version eproject-version)
 278 )
 279
 280 (defun prj-get-frame-pos (f)
 281   (and f
 282        (mapcar
 283         (lambda (parm) (cons parm (frame-parameter f parm)))
 284         '(top left width height)
 285         )))
 286
 287 (defun prj-savelist ()
 288   (let ((g (prj-globalfile))
 289         fp
 290         )
 291     (unless (file-exists-p g)
 292       (make-directory (file-name-directory g) t)
 293       )
 294     (setq prj-last-open (car prj-current))
 295     (when (frame-live-p prj-initial-frame)
 296       (setq prj-frame-pos (prj-get-frame-pos prj-initial-frame))
 297       )
 298     (setq fp (prj-create-file g))
 299     (when fp
 300       (prj-print-list 'prj-version fp)
 301       (prj-print-list 'prj-list fp)
 302       (prj-print-list 'prj-last-open fp)
 303       (prj-print-list 'prj-frame-pos fp)
 304       (prj-close-file fp)
 305       )))
 306
 307 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 308 ;; Load/Save local per-project configuration file
 309
 310 (defun prj-update-config ()
 311   (setq prj-directory-run
 312         (file-name-as-directory
 313          (expand-file-name
 314           (or (prj-getconfig "run-directory") ".")
 315           prj-directory
 316           )))
 317   )
 318
 319 (defun prj-loadconfig (a)
 320   (let (lf e)
 321     (prj-reset)
 322     (setq prj-current a)
 323     (setq prj-directory
 324           (file-name-as-directory
 325            (expand-file-name (cadr a))
 326            ))
 327
 328     (when (file-exists-p (setq lf (prj-localfile)))
 329       (load lf nil t)
 330       (setq prj-curfile
 331         (or (assoc prj-curfile prj-files)
 332             (car prj-files)
 333             ))
 334       )
 335     (if (setq e (prj-getconfig "project-name"))
 336         (setcar a e)
 337         (prj-setconfig "project-name" (car a))
 338         )
 339     (prj-update-config)
 340     (prj-set-functions prj-functions)
 341     (setq prj-version eproject-version)
 342     ))
 343
 344 (defun prj-saveconfig ()
 345   (when prj-current
 346     (let (w c b files)
 347       (prj-removehooks)
 348       (setq w (selected-window))
 349       (setq c (window-buffer w))
 350       (dolist (f prj-files)
 351         (cond ((setq b (get-buffer (car f)))
 352                (set-window-buffer w b t)
 353                (with-current-buffer b
 354                  (let ((s (line-number-at-pos (window-start w)))
 355                        (p (line-number-at-pos (window-point w)))
 356                        )
 357                    (push (list (car f) s p) files)
 358                    )))
 359               ((consp (cdr f))
 360                (push f files)
 361                )))
 362       (set-window-buffer w c t)
 363       (prj-addhooks)
 364       (let ((fp (prj-create-file (prj-localfile)))
 365             (prj-curfile (car prj-curfile))
 366             (prj-files (nreverse files))
 367             )
 368         (when fp
 369           (prj-print-list 'prj-version fp)
 370           (prj-print-list 'prj-config fp)
 371           (prj-print-list 'prj-tools fp)
 372           (prj-print-list 'prj-files fp)
 373           (prj-print-list 'prj-curfile fp)
 374           (prj-print-list 'prj-functions fp)
 375           (prj-close-file fp)
 376           ))
 377       )))
 378
 379 (defun prj-saveall ()
 380   (prj-saveconfig)
 381   (prj-savelist)
 382   )
 383
 384 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 385 ;; The core functions:  Open / Close / Add / Remove  Project
 386
 387 (defun eproject-open (a)
 388   "Open another project."
 389   (interactive
 390    (list
 391     (or (prj-config-get-result 'p)
 392         (completing-read "Open Project: " (mapcar 'car prj-list))
 393         )))
 394   (unless (consp a)
 395     (let ((b (assoc a prj-list)))
 396       (unless b
 397         (error "No such project: %s" a)
 398         )
 399       (setq a b)
 400       ))
 401   (setq a (or (car (member a prj-list)) a))
 402   (unless (eq a prj-current)
 403     (unless (file-directory-p (cadr a))
 404       (error "Error: No such directory: %s" (cadr a))
 405       )
 406     (setq prj-list (cons a (delq a prj-list)))
 407     (eproject-close)
 408     (prj-loadconfig a)
 409     )
 410   (prj-addhooks)
 411   (prj-setup-all)
 412   (cd prj-directory)
 413   (unless (prj-edit-file prj-curfile)
 414     (eproject-dired)
 415     ))
 416
 417 (defun eproject-close ()
 418   "Close the current project."
 419   (interactive)
 420   (when prj-current
 421     (prj-saveconfig)
 422     (prj-removehooks)
 423     (let (f)
 424       (unwind-protect
 425           (progn
 426             (save-some-buffers nil)
 427             (eproject-killbuffers t)
 428             (setq f t)
 429             )
 430         (or f (prj-addhooks))
 431         ))
 432     (prj-reset)
 433     (prj-config-reset)
 434     (prj-setup-all)
 435     ))
 436
 437 (defun eproject-killbuffers (&optional from-project)
 438   "If called interactively kills all buffers that
 439 do not belong to  project files"
 440   (interactive)
 441   (let (a b)
 442     (dolist (f prj-files)
 443       (setq b (get-buffer (car f)))
 444       (if b
 445           (setq a (cons (list b) a))
 446           ))
 447     (dolist (b (buffer-list))
 448       (when (eq (consp (assoc b a)) from-project)
 449         (kill-buffer b)
 450         ))))
 451
 452 (defun eproject-add (d)
 453   "Add a new or existing project to the list."
 454   (interactive
 455    (list
 456     (read-directory-name "Add project in directory: " prj-directory nil t)
 457     ))
 458   (when d
 459     (setq d (directory-file-name d))
 460     )
 461   (when (= 0 (length d))
 462     (error "Error: Empty directory name.")
 463     )
 464   (let (n a)
 465     (setq n (file-name-nondirectory d))
 466     (setq a (list n d))
 467     (push a prj-list)
 468     (prj-setup-all)
 469     ))
 470
 471 (defun eproject-remove (a)
 472   "Remove a project from the list."
 473   (interactive
 474    (list
 475     (or (prj-config-get-result 'p)
 476         (completing-read "Remove project: " (mapcar 'car prj-list))
 477         )))
 478   (unless (consp a)
 479     (let ((b (assoc a prj-list)))
 480       (unless b
 481         (error "No such project: %s" a)
 482         )
 483       (setq a b)
 484       ))
 485   (when (progn
 486           (beep)
 487           (prog1 (y-or-n-p (format "Remove \"%s\"? " (car a)))
 488             (message "")
 489             ))
 490     (setq prj-list (prj-del-list prj-list a))
 491     (prj-setup-all)
 492     ))
 493
 494 (defun eproject-save ()
 495   "Save the project configuration to file."
 496   (interactive)
 497   (prj-config-parse)
 498   (prj-config-print)
 499   (prj-saveall)
 500   )
 501
 502 (defun eproject-revert ()
 503   "Reload the project configuration from file."
 504   (interactive)
 505   (prj-loadlist)
 506   (if prj-current
 507       (prj-loadconfig prj-current)
 508     )
 509   (prj-setup-all)
 510   )
 511
 512 (defun eproject-addfile (f)
 513   "Add a file to the current project."
 514   (interactive
 515    (and prj-current
 516         (list
 517          (read-file-name "Add file to project: " nil nil t nil)
 518          )))
 519   (unless prj-current (error "No project open"))
 520   (let ((a (prj-insert-file f (prj-config-get-result 'f))))
 521     (unless (cdr a)
 522       (message "Added to project: %s" (car a))
 523       ))
 524   (prj-config-print)
 525   (prj-setmenu)
 526   )
 527
 528 (defun eproject-removefile (a)
 529   "Remove a file from the current project."
 530   (interactive (prj-get-existing-file-1 "Remove file from project: "))
 531   (setq a (prj-get-existing-file-2 a))
 532   (prj-remove-file a)
 533   )
 534
 535 (defun eproject-visitfile (a)
 536   "Visit a file from the current project."
 537   (interactive (prj-get-existing-file-1 "Visit file: "))
 538   (setq a (prj-get-existing-file-2 a))
 539   (prj-edit-file a)
 540    )
 541
 542 (defun prj-get-existing-file-1 (msg)
 543   (and prj-current
 544        (list
 545         (or (prj-config-get-result 'f)
 546             (completing-read msg (mapcar 'car prj-files))
 547             ))))
 548
 549 (defun prj-get-existing-file-2 (a)
 550    (unless prj-current (error "No project open"))
 551    (if (consp a)
 552        a
 553      (let ((b (assoc (prj-relative-path a) prj-files)))
 554        (unless b (error "No such file in project: %s" a))
 555        b
 556        )))
 557
 558 (defun eproject-help ()
 559   "Show the eproject README."
 560   (interactive)
 561   (view-file (eproject-addon "eproject.txt"))
 562   )
 563
 564 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 565 ;; Hook functions to track opening/closing files from emacs
 566
 567 (defun prj-addhooks ()
 568   (add-hook 'kill-buffer-hook 'prj-kill-buffer-hook)
 569   (add-hook 'find-file-hook 'prj-find-file-hook)
 570   (add-hook 'window-configuration-change-hook 'prj-wcc-hook)
 571   )
 572
 573 (defun prj-removehooks ()
 574   (remove-hook 'window-configuration-change-hook 'prj-wcc-hook)
 575   (remove-hook 'find-file-hook 'prj-find-file-hook)
 576   (remove-hook 'kill-buffer-hook 'prj-kill-buffer-hook)
 577   )
 578
 579 (defun prj-wcc-hook ()
 580   (let ((w (selected-window)) (b (window-buffer (selected-window))))
 581     ;; (message "wcc-hook: %s" (prin1-to-string (list wcc-count w b n)))
 582     (prj-register-buffer b)
 583     ))
 584
 585 (defun prj-find-file-hook ()
 586   (run-with-idle-timer
 587    0
 588    nil
 589    `(lambda () (prj-register-buffer ,(current-buffer)))
 590    ))
 591
 592 (defun prj-kill-buffer-hook ()
 593   (let ((b (current-buffer)) a)
 594     (if (setq a (rassq b prj-files))
 595         (prj-remove-file a t)
 596         (if (setq a (rassq b prj-removed-files))
 597             (setq prj-removed-files (delq a prj-removed-files))
 598           ))))
 599
 600 (defun prj-register-buffer (b)
 601   (let (f a i)
 602     (setq f (buffer-file-name b))
 603     (when f
 604       (setq a (rassq b prj-files))
 605       (unless a
 606         (setq a (prj-insert-file f nil t))
 607         (when a
 608           (unless (cdr a)
 609             (message "Added to project: %s" (car a))
 610             )
 611           (setcdr a b)
 612           (with-current-buffer b
 613             (rename-buffer (car a) t)
 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     (when (eq prj-curfile a)
 639       (setq prj-curfile n)
 640       )
 641     (unless on-the-fly
 642         (setq prj-removed-files (prj-add-list prj-removed-files a))
 643         )
 644     (unless (prj-config-print)
 645       (prj-edit-file prj-curfile)
 646       )
 647     (prj-setmenu)
 648     (message "Removed from project: %s" (car a))
 649     ))
 650
 651 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 652 ;; Edit another file
 653
 654 (defun prj-edit-file (a)
 655   (when a
 656     (let ((n (car a)) f b pos)
 657       (setq f (expand-file-name n prj-directory))
 658       (setq b (get-file-buffer f))
 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)) (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 (funcall fn1 prj-files 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           (list
 770            `("Open" open
 771              ,@(prj-menulist-maker prj-list prj-current 'prj-menu-open)
 772              ("--")
 773              ("Add ..." "Add new or existing project to the list" . eproject-add)
 774              ("Remove ..." "Remove project from the list" . eproject-remove)
 775              ,@(and f '(("Close" "Close current project" . eproject-close)))
 776              )
 777            '("Setup" "Enter the project setup area." . eproject-setup-toggle)
 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-directory-run
 939       (setq dir (expand-file-name (or dir ".") prj-directory-run))
 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))
 958              (compile cmd)
 959              )))))
 960
 961 (defun prj-run-tool (a)
 962   (unless (string-match "^--+$" (car a))
 963     (prj-run (or (cadr a) (car a)))
 964     ))
 965
 966 (defun eproject-killtool ()
 967   (interactive)
 968   (let ((bn "*compilation*") w0 w1)
 969     (when (setq w1 (get-buffer-window bn t))
 970       (when (fboundp 'kill-compilation)
 971         (setq w0 (selected-window))
 972         (select-window w1)
 973         (kill-compilation)
 974         (select-window w0)
 975         ))))
 976
 977 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 978 ;; run grep on project files
 979
 980 (require 'grep)
 981
 982 (defun eproject-grep (command-args)
 983   "Run the grep command on all the project files."
 984   (interactive
 985    (progn
 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-run
1034     (eproject-setup-quit)
1035     ;;(message "Use 'a' to add marked or single files to the project.")
1036     (dired prj-directory-run)
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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1069 ;; Initialize
1070
1071 (defun prj-startup-delayed ()
1072   ;; where is this file
1073   (setq eproject-directory
1074     (file-name-directory (symbol-file 'eproject-startup)))
1075
1076   ;; load UI support
1077   (load (eproject-addon "eproject-config") nil t)
1078
1079   ;; When no projects are specified yet, load the eproject project itself.
1080   (unless prj-list
1081     (load (eproject-addon "eproject.cfg"))
1082     )
1083
1084   ;; no project so far
1085   (prj-reset)
1086   (prj-setup-all)
1087   (add-hook 'kill-emacs-hook 'prj-saveall)
1088
1089   ;; inhibit open last project when a file was on the commandline
1090   (unless (buffer-file-name (window-buffer))
1091     (when prj-last-open
1092
1093       ;; open last project
1094       (eproject-open prj-last-open)
1095
1096       ;; restore frame position
1097       (unless (fboundp 'ewm-init)
1098         (when prj-frame-pos
1099           (modify-frame-parameters prj-initial-frame prj-frame-pos)
1100           ;; emacs bug: when it's too busy it doesn't set frames correctly.
1101           (sit-for 0.2)
1102           ))))
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