← Back to branch summary

~ubuntu-branches/ubuntu/oneiric/muse-el/oneiric

« back to all changes in this revision

Viewing changes to lisp/muse-project.el

  • Committer: Bazaar Package Importer
  • Author(s): Michael W. Olson (GNU address)
  • Date: 2008-01-09 15:51:46 UTC
  • mto: This revision was merged to the branch mainline in revision 6.
  • Revision ID: james.westby@ubuntu.com-20080109155146-vkc4ohnzv96spdpm
Tags: upstream-3.11
Import upstream version 3.11

Show diffs side-by-side

added added

removed removed

Lines of Context:
lisp/muse-project.el
6
6
 
7
7
;; Emacs Muse is free software; you can redistribute it and/or modify
8
8
;; it under the terms of the GNU General Public License as published
9
 
;; by the Free Software Foundation; either version 2, or (at your
 
9
;; by the Free Software Foundation; either version 3, or (at your
10
10
;; option) any later version.
11
11
 
12
12
;; Emacs Muse is distributed in the hope that it will be useful, but
436
436
contents have changed.  On Windows, it is always reread from
437
437
disk."
438
438
  (setq project (muse-project project))
439
 
  (let* ((file-alist (assoc (car project) muse-project-file-alist))
440
 
         (last-mod (cdr (cdr file-alist))))
441
 
    ;; Determine the last modified of any directory mentioned in the
442
 
    ;; project's pattern list
443
 
    (unless (or muse-under-windows-p no-check-p)
444
 
      (let ((pats (cadr project)))
445
 
        (while pats
446
 
          (if (symbolp (car pats))
447
 
              (setq pats (cddr pats))
448
 
            (let* ((fnd (file-name-directory (car pats)))
449
 
                   (dir (cond ((file-directory-p (car pats))
450
 
                               (car pats))
451
 
                              ((and (not (file-readable-p (car pats)))
452
 
                                    fnd
453
 
                                    (file-directory-p fnd))
454
 
                               fnd))))
455
 
              (when dir
456
 
                (let ((mod-time (nth 5 (file-attributes dir))))
457
 
                  (when (or (null last-mod)
458
 
                            (and mod-time
459
 
                                 (muse-time-less-p last-mod mod-time)))
460
 
                    (setq last-mod mod-time)))))
461
 
            (setq pats (cdr pats))))))
462
 
    ;; Either return the currently known list, or read it again from
463
 
    ;; disk
464
 
    (if (or (and no-check-p (cadr file-alist))
465
 
            muse-updating-file-alist-p
466
 
            (not (or muse-under-windows-p
467
 
                     (null (cddr file-alist))
468
 
                     (null last-mod)
469
 
                     (muse-time-less-p (cddr file-alist) last-mod))))
470
 
        (cadr file-alist)
471
 
      (if file-alist
472
 
          (setcdr (cdr file-alist) last-mod)
473
 
        (setq file-alist (cons (car project) (cons nil last-mod))
474
 
              muse-project-file-alist
475
 
              (cons file-alist muse-project-file-alist)))
476
 
      ;; Read in all of the file entries
477
 
      (let ((muse-updating-file-alist-p t))
478
 
        (prog1
479
 
            (save-match-data
480
 
              (setcar
481
 
               (cdr file-alist)
482
 
               (let* ((names (list t))
483
 
                      (pats (cadr project)))
484
 
                 (while pats
485
 
                   (if (symbolp (car pats))
486
 
                       (setq pats (cddr pats))
487
 
                     (nconc names (muse-project-file-entries (car pats)))
488
 
                     (setq pats (cdr pats))))
489
 
                 (cdr names))))
490
 
          (run-hooks 'muse-project-file-alist-hook))))))
 
439
  (when (and project muse-project-alist)
 
440
    (let* ((file-alist (assoc (car project) muse-project-file-alist))
 
441
           (last-mod (cdr (cdr file-alist))))
 
442
      ;; Determine the last modified of any directory mentioned in the
 
443
      ;; project's pattern list
 
444
      (unless (or muse-under-windows-p no-check-p)
 
445
        (let ((pats (cadr project)))
 
446
          (while pats
 
447
            (if (symbolp (car pats))
 
448
                (setq pats (cddr pats))
 
449
              (let* ((fnd (file-name-directory (car pats)))
 
450
                     (dir (cond ((file-directory-p (car pats))
 
451
                                 (car pats))
 
452
                                ((and (not (file-readable-p (car pats)))
 
453
                                      fnd
 
454
                                      (file-directory-p fnd))
 
455
                                 fnd))))
 
456
                (when dir
 
457
                  (let ((mod-time (nth 5 (file-attributes dir))))
 
458
                    (when (or (null last-mod)
 
459
                              (and mod-time
 
460
                                   (muse-time-less-p last-mod mod-time)))
 
461
                      (setq last-mod mod-time)))))
 
462
              (setq pats (cdr pats))))))
 
463
      ;; Either return the currently known list, or read it again from
 
464
      ;; disk
 
465
      (if (or (and no-check-p (cadr file-alist))
 
466
              muse-updating-file-alist-p
 
467
              (not (or muse-under-windows-p
 
468
                       (null (cddr file-alist))
 
469
                       (null last-mod)
 
470
                       (muse-time-less-p (cddr file-alist) last-mod))))
 
471
          (cadr file-alist)
 
472
        (if file-alist
 
473
            (setcdr (cdr file-alist) last-mod)
 
474
          (setq file-alist (cons (car project) (cons nil last-mod))
 
475
                muse-project-file-alist
 
476
                (cons file-alist muse-project-file-alist)))
 
477
        ;; Read in all of the file entries
 
478
        (let ((muse-updating-file-alist-p t))
 
479
          (prog1
 
480
              (save-match-data
 
481
                (setcar
 
482
                 (cdr file-alist)
 
483
                 (let* ((names (list t))
 
484
                        (pats (cadr project)))
 
485
                   (while pats
 
486
                     (if (symbolp (car pats))
 
487
                         (setq pats (cddr pats))
 
488
                       (nconc names (muse-project-file-entries (car pats)))
 
489
                       (setq pats (cdr pats))))
 
490
                   (cdr names))))
 
491
            (run-hooks 'muse-project-file-alist-hook)))))))
491
492
 
492
493
(defun muse-project-of-file (&optional pathname)
493
494
  "Determine which project the given PATHNAME relates to.
497
498
    (unless pathname (setq pathname (muse-current-file)))
498
499
    (save-match-data
499
500
      (when (and (stringp pathname)
 
501
                 muse-project-alist
500
502
                 (not (string= pathname ""))
501
503
                 (not (let ((case-fold-search nil))
502
504
                        (or (string-match muse-project-ignore-regexp
506
508
                                           pathname))))))
507
509
        (let* ((file (file-truename pathname))
508
510
               (dir  (file-name-directory file))
509
 
               (project-entry muse-project-alist)
510
 
               found)
511
 
          (while (and project-entry (not found))
512
 
            (let ((pats (car (cdar project-entry))))
513
 
              (while (and pats (not found))
514
 
                (if (symbolp (car pats))
515
 
                    (setq pats (cddr pats))
516
 
                  (let ((truename (file-truename (car pats))))
517
 
                    (if (or (string= truename file)
518
 
                            (string= truename dir)
519
 
                            (string-match (regexp-quote truename) file))
520
 
                        (setq found (car project-entry))))
521
 
                  (setq pats (cdr pats))))
522
 
              (setq project-entry (cdr project-entry))))
523
 
          found)))))
 
511
               found rating matches)
 
512
          (catch 'found
 
513
            (dolist (project-entry muse-project-alist)
 
514
              (let ((pats (cadr project-entry)))
 
515
                (while pats
 
516
                  (if (symbolp (car pats))
 
517
                      (setq pats (cddr pats))
 
518
                    (let ((tname (file-truename (car pats))))
 
519
                      (cond ((or (string= tname file)
 
520
                                 (string= tname dir))
 
521
                             (throw 'found project-entry))
 
522
                            ((string-match (concat "\\`" (regexp-quote tname))
 
523
                                           file)
 
524
                             (setq matches (cons (cons (match-end 0)
 
525
                                                       project-entry)
 
526
                                                 matches)))))
 
527
                    (setq pats (cdr pats))))))
 
528
            ;; if we haven't found an exact match, pick a candidate
 
529
            (car (muse-sort-by-rating matches))))))))
524
530
 
525
531
(defun muse-project-after-save-hook ()
526
532
  "Update Muse's file-alist if we are saving a Muse file."
540
546
        (if (and (not no-assume)
541
547
                 (= 1 (length muse-project-alist)))
542
548
            (car muse-project-alist)
543
 
          (assoc (completing-read prompt muse-project-alist)
 
549
          (assoc (funcall muse-completing-read-function
 
550
                          prompt muse-project-alist)
544
551
                 muse-project-alist)))))
545
552
 
546
553
(defvar muse-project-page-history nil)
547
554
 
548
555
(defun muse-read-project-file (project prompt &optional default)
549
 
  (let ((name (completing-read prompt (muse-project-file-alist project)
550
 
                               nil nil nil 'muse-project-page-history
551
 
                               default)))
 
556
  (let ((name (funcall muse-completing-read-function
 
557
                       prompt (muse-project-file-alist project)
 
558
                       nil nil nil 'muse-project-page-history
 
559
                       default)))
552
560
    (cons name (muse-project-page-file name project))))
553
561
 
554
562
;;;###autoload
625
633
    (and (stringp link-suffix)
626
634
         (string= given-suffix link-suffix))))
627
635
 
628
 
(defun muse-project-applicable-styles (file styles &optional ignore-regexp)
 
636
(defun muse-project-applicable-styles (file styles)
629
637
  "Given STYLES, return a list of the ones that are considered for FILE.
630
638
The name of a project may be used for STYLES."
631
639
  (when (stringp styles)
636
644
        (let ((include-regexp (muse-style-element :include style))
637
645
              (exclude-regexp (muse-style-element :exclude style))
638
646
              (rating nil))
639
 
          (when (and (or ignore-regexp
640
 
                         (and (null include-regexp)
 
647
          (when (and (or (and (null include-regexp)
641
648
                              (null exclude-regexp))
642
649
                         (if include-regexp
643
650
                             (setq rating (string-match include-regexp file))
644
651
                           (not (string-match exclude-regexp file))))
645
 
                     (or (not (file-exists-p file))
646
 
                         (not (muse-project-private-p file))))
 
652
                     (file-exists-p file)
 
653
                     (not (muse-project-private-p file)))
647
654
            (setq used-styles (cons (cons rating style) used-styles)))))
648
655
      (muse-sort-by-rating (nreverse used-styles)))))
649
656
 
655
662
             (cons (muse-get-keyword :base style) style))
656
663
           (muse-project-applicable-styles file styles))))
657
664
 
 
665
(defun muse-project-resolve-directory (page local-style remote-style)
 
666
  "Figure out the directory part of the path that provides a link to PAGE.
 
667
LOCAL-STYLE is the style of the current Muse file, and
 
668
REMOTE-STYLE is the style associated with PAGE.
 
669
 
 
670
If REMOTE-STYLE has a :base-url element, concatenate it and PAGE.
 
671
Otherwise, return a relative link."
 
672
  (let ((prefix (muse-style-element :base-url remote-style)))
 
673
    (if prefix
 
674
        (concat prefix page)
 
675
      (file-relative-name (expand-file-name
 
676
                           (file-name-nondirectory page)
 
677
                           (muse-style-element :path remote-style))
 
678
                          (expand-file-name
 
679
                           (muse-style-element :path local-style))))))
 
680
 
658
681
(defun muse-project-resolve-link (page local-style remote-styles)
659
 
  "Return a published relative link from the output path of one file
660
 
to another file.
 
682
  "Return a published link from the output path of one file to another file.
661
683
 
662
684
The best match for PAGE is determined by comparing the link
663
685
suffix of the given local style and that of the remote styles.
664
686
 
665
687
The remote styles are usually populated by
666
 
`muse-project-applicable-styles'."
 
688
`muse-project-applicable-styles'.
 
689
 
 
690
If no remote style is found, return PAGE verbatim
 
691
 
 
692
If PAGE has a :base-url associated with it, return the
 
693
concatenation of the :base-url value and PAGE.
 
694
 
 
695
Otherwise, return a relative path from the directory of
 
696
LOCAL-STYLE to the best directory among REMOTE-STYLES."
667
697
  (let ((link-suffix (or (muse-style-element :link-suffix local-style)
668
698
                         (muse-style-element :suffix local-style)))
669
699
        remote-style)
675
705
                          remote-styles)))
676
706
    (if (null remote-style)
677
707
        page
678
 
      (muse-publish-link-file
679
 
       (let ((prefix (muse-style-element :base-url remote-style)))
680
 
         (if prefix
681
 
             (concat prefix page)
682
 
           (file-relative-name (expand-file-name
683
 
                                (file-name-nondirectory page)
684
 
                                (muse-style-element :path remote-style))
685
 
                               (expand-file-name
686
 
                                (muse-style-element :path local-style)))))
687
 
       remote-style))))
 
708
      (setq page (muse-project-resolve-directory
 
709
                  page local-style remote-style))
 
710
      (concat (file-name-directory page)
 
711
              (muse-publish-link-name page remote-style)))))
688
712
 
689
713
(defun muse-project-current-output-style (&optional file project)
690
714
  (or muse-current-output-style
709
733
  ;; publish the member file!
710
734
  (muse-publish-file file style output-dir force))
711
735
 
712
 
(defun muse-project-publish-file (file styles &optional force ignore-regexp)
713
 
  (setq styles (muse-project-applicable-styles file styles ignore-regexp))
 
736
(defun muse-project-publish-file (file styles &optional force)
 
737
  (setq styles (muse-project-applicable-styles file styles))
714
738
  (let (published)
715
739
    (dolist (style styles)
716
740
      (if (or (not (listp style))
733
757
 
734
758
If FORCE is given, publish the file even if it is up-to-date."
735
759
  (interactive (list current-prefix-arg))
736
 
  (let* ((style (muse-project-get-applicable-style
737
 
                buffer-file-name (cddr muse-current-project)))
738
 
         (output-dir (muse-style-element :path style)))
739
 
    (unless (muse-publish-file buffer-file-name style output-dir force)
740
 
      (message (concat "The published version is up-to-date; use"
741
 
                       " C-u C-c C-t to force an update.")))))
 
760
  (let ((muse-current-project (muse-project-of-file)))
 
761
    (if (not muse-current-project)
 
762
        ;; file is not part of a project, so fall back to muse-publish
 
763
        (if (interactive-p) (call-interactively 'muse-publish-this-file)
 
764
          (muse-publish-this-file nil nil force))
 
765
      (let* ((style (muse-project-get-applicable-style
 
766
                     buffer-file-name (cddr muse-current-project)))
 
767
             (output-dir (muse-style-element :path style))
 
768
             (muse-current-output-style (list :base (car style)
 
769
                                              :path output-dir)))
 
770
        (unless (muse-publish-file buffer-file-name style output-dir force)
 
771
          (message (concat "The published version is up-to-date; use"
 
772
                           " C-u C-c C-t to force an update.")))))))
742
773
 
743
774
(defun muse-project-save-buffers (&optional project)
744
775
  (setq project (muse-project project))
745
 
  (map-y-or-n-p
746
 
   (function
747
 
    (lambda (buffer)
748
 
      (and (buffer-modified-p buffer)
749
 
           (not (buffer-base-buffer buffer))
750
 
           (or (buffer-file-name buffer)
751
 
               (progn
752
 
                 (set-buffer buffer)
753
 
                 (and buffer-offer-save
754
 
                      (> (buffer-size) 0))))
755
 
           (with-current-buffer buffer
756
 
             (let ((proj (muse-project-of-file)))
757
 
               (and proj (string= (car proj)
758
 
                                  (car project)))))
759
 
           (if (buffer-file-name buffer)
760
 
               (format "Save file %s? "
761
 
                       (buffer-file-name buffer))
762
 
             (format "Save buffer %s? "
763
 
                     (buffer-name buffer))))))
764
 
   (function
765
 
    (lambda (buffer)
766
 
      (set-buffer buffer)
767
 
      (save-buffer)))
768
 
   (buffer-list)
769
 
   '("buffer" "buffers" "save")
770
 
   (if (boundp 'save-some-buffers-action-alist)
771
 
       save-some-buffers-action-alist)))
 
776
  (when project
 
777
    (map-y-or-n-p
 
778
     (function
 
779
      (lambda (buffer)
 
780
        (and (buffer-modified-p buffer)
 
781
             (not (buffer-base-buffer buffer))
 
782
             (or (buffer-file-name buffer)
 
783
                 (progn
 
784
                   (set-buffer buffer)
 
785
                   (and buffer-offer-save
 
786
                        (> (buffer-size) 0))))
 
787
             (with-current-buffer buffer
 
788
               (let ((proj (muse-project-of-file)))
 
789
                 (and proj (string= (car proj)
 
790
                                    (car project)))))
 
791
             (if (buffer-file-name buffer)
 
792
                 (format "Save file %s? "
 
793
                         (buffer-file-name buffer))
 
794
               (format "Save buffer %s? "
 
795
                       (buffer-name buffer))))))
 
796
     (function
 
797
      (lambda (buffer)
 
798
        (set-buffer buffer)
 
799
        (save-buffer)))
 
800
     (buffer-list)
 
801
     '("buffer" "buffers" "save")
 
802
     (if (boundp 'save-some-buffers-action-alist)
 
803
         save-some-buffers-action-alist))))
772
804
 
773
805
(defun muse-project-publish-default (project styles &optional force)
774
806
  "Publish the pages of PROJECT that need publishing."
846
878
      (funcall custom-set var (car (cdr vars)))
847
879
      (setq vars (cdr (cdr vars))))))
848
880
 
 
881
(custom-add-option 'muse-before-publish-hook 'muse-project-set-variables)
 
882
(add-to-list 'muse-before-publish-hook 'muse-project-set-variables)
 
883
 
849
884
(defun muse-project-delete-output-files (project)
850
885
  (interactive
851
886
   (list (muse-read-project "Remove all output files for project: " nil t)))