--- /dev/null
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; This program is free software; you can redistribute it and/or ;;
+;; modify it under the terms of the GNU General Public License as ;;
+;; published by the Free Software Foundation; either version 3, or (at ;;
+;; your option) any later version. ;;
+;; ;;
+;; This program is distributed in the hope that it will be useful, but ;;
+;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;
+;; General Public License for more details. ;;
+;; ;;
+;; You should have received a copy of the GNU General Public License ;;
+;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;
+;; ;;
+;; Written by and Copyright (C) Francois Fleuret ;;
+;; Contact <francois@fleuret.org> for comments & bug reports ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; These functions display an alarm in the mode-line if the file in
+;; the current buffer is not under CVS, subversion or GIT while the
+;; directory is. You just have to put (load "alarm-vc") in your
+;; ~/.emacs to make the thing work.
+
+;; I also have (setq alarm-vc-mode-exceptions "^VM") to prevent alarms
+;; to be displayed in my VM buffers
+
+;; Jan 9th 2009
+
+(require 'vc-cvs nil t)
+(require 'vc-svn nil t)
+(require 'vc-git nil t)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defface alarm-vc-face
+ '((((background light)) (:background "yellow"))
+ (((background dark)) (:background "yellow")))
+ "The face for the alarm-vc modeline message.")
+
+(defcustom alarm-vc-mode-exceptions nil
+ "*Regexp defining the mode names which should be ignored by
+alarm-vc."
+ :type 'string)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(make-variable-buffer-local 'alarm-vc-string)
+
+(defun alarm-vc-mode-line ()
+ ;; We check the mode name here since it can change after the opening
+ ;; of the file, hence after we have computed alarm-vc-string
+ (unless
+ (and alarm-vc-mode-exceptions
+ (string-match alarm-vc-mode-exceptions mode-name))
+ alarm-vc-string))
+
+(defun alarm-vc-check ()
+ "Adds an alarm in the modeline if the file in the current
+buffer is not under some VC system while it looks like it
+should."
+
+ (if buffer-file-name
+
+ (let ((id
+ (concat
+
+ ;; CVS
+ (if (and (fboundp 'vc-cvs-registered)
+ (vc-cvs-responsible-p buffer-file-name)
+ (not (vc-cvs-registered buffer-file-name)))
+ " CVS")
+
+ ;; Subversion
+ (if (and (fboundp 'vc-svn-registered)
+ (vc-svn-responsible-p buffer-file-name)
+ (not (vc-svn-registered buffer-file-name)))
+ " SVN")
+
+ ;; GIT
+ (if (and (fboundp 'vc-git-registered)
+ ;; does not exist in old emacs
+ (fboundp 'vc-git-responsible-p)
+ (vc-git-responsible-p buffer-file-name)
+ (not (vc-git-registered buffer-file-name)))
+ " GIT")
+
+ )))
+
+ (setq alarm-vc-string
+ (if (string= id "") ""
+ (concat " "
+ (propertize (concat "Not under" id) 'face 'alarm-vc-face)
+ " ")
+ ))
+
+ ))
+
+ ;; Returns nil so that the file is not considered as saved when
+ ;; the function is called by write-file-functions
+
+ nil)
+
+(setq global-mode-string (cons '(:eval (alarm-vc-mode-line)) global-mode-string))
+
+;; Refreshes the alarm when opening or saving a file
+
+(add-hook 'find-file-hooks 'alarm-vc-check)
+(add-hook 'write-file-hooks 'alarm-vc-check)
+
+;; Since there is no hook called when one register a file through
+;; version control, we need an advice.
+
+(defadvice vc-register (after alarm-vc-check nil activate)
+ (alarm-vc-check))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
--- /dev/null
+
+;; -*-Emacs-Lisp-*-
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; This program is free software; you can redistribute it and/or ;;
+;; modify it under the terms of the GNU General Public License as ;;
+;; published by the Free Software Foundation; either version 3, or (at ;;
+;; your option) any later version. ;;
+;; ;;
+;; This program is distributed in the hope that it will be useful, but ;;
+;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;
+;; General Public License for more details. ;;
+;; ;;
+;; You should have received a copy of the GNU General Public License ;;
+;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;
+;; ;;
+;; Written by and Copyright (C) Francois Fleuret ;;
+;; Contact <francois@fleuret.org> for comments & bug reports ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; This file contains functions to handle rendez-vous and
+;; appointments. It has a list of 'notes', each defined by a date, a
+;; title, a warning date and optionnaly a tag color and a string of
+;; information. The system automatically opens a window when an alarm
+;; has to be displayed.
+
+;; Just call enotes/init to load the notes saved during the last
+;; session and run the whole stuff. The notes are kept in the variable
+;; enotes/notes and saved when a note is added or when emacs is
+;; killed.
+
+;; You can bring the main buffer containing all notes by calling
+;; enotes/show-all-notes. The defined keys are given at the top of
+;; that buffer.
+
+;; I use the following in my .emacs
+;;
+;; ;; Load the script itself
+;; (load "enotes")
+;; ;; Load the notes and display the required alarms
+;; (enotes/init)
+;; ;; That short-cuts to edit all the notes
+;; (define-key global-map [(control x) (control n)] 'enotes/show-all-notes)
+;;
+;; Check the defcustom in the source below to see the tunable
+;; variables.
+
+(eval-when-compile (require 'cl))
+
+(require 'time-date)
+(require 'parse-time)
+
+(defgroup enotes ()
+ "Set of functions to handle notes and rendez-vous."
+ :version "1.3.1")
+
+(provide 'enotes)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defcustom enotes/file "~/.enotes"
+ "File containing the list of notes."
+ :type 'string
+ :group 'enotes)
+
+(defcustom enotes/alarm-hook nil
+ "Hook called when alarms are to be displayed."
+ :type 'hook
+ :group 'enotes)
+
+(defcustom enotes/input-time-format "%Y %b %d %H:%M"
+ "The time format for input."
+ :type 'string
+ :group 'enotes)
+
+(defcustom enotes/time-format "%h %a %d %Y %H:%M"
+ "The time format."
+ :type 'string
+ :group 'enotes)
+
+(defcustom enotes/show-help t
+ "Should the key help be displayed."
+ :type 'boolean
+ :group 'enotes)
+
+(defcustom enotes/full-display t
+ "Should the infos be displayed."
+ :type 'boolean
+ :group 'enotes)
+
+(defcustom enotes/display-mode 'enotes/insert-all-notes-by-week
+ "How to show the notes. Either `enotes/insert-all-notes-by-delay' or
+`enotes/insert-all-notes-by-week'."
+ :type 'function
+ :group 'enotes)
+
+(defcustom enotes/color-list '("red" "green3" "yellow" "blue")
+ "What colors can be given to the tags in front of the note titles"
+ :type 'list
+ :group 'enotes)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defconst enotes/help-string " n,TAB: go to next note p,S-TAB: go to prev note
+ a: add note C-d,DEL: delete note
+ e: edit field at point c: change tag color
+ d: edit event time w: edit warning time
+ i: edit information I: switch full display
+ +: move event +1h =: move warning +1h
+ T: move event +24h t: move warning +24h
+ f: force warning time at event time
+ h: show/hide help m: switch display mode
+ u: undo r: redo
+ s: save notes RET,g: go to reference
+ q: quit Q: remove obsolete notes and quit
+
+ Contact <francois@fleuret.org> for remarks & bug reports.")
+
+(defmacro enotes/get-event-time (note) `(elt ,note 0))
+(defmacro enotes/get-warning-time (note) `(elt ,note 1))
+(defmacro enotes/get-note-time (note) `(elt ,note 2))
+(defmacro enotes/get-title (note) `(elt ,note 3))
+(defmacro enotes/get-ref (note) `(elt ,note 4))
+(defmacro enotes/get-info (note) `(elt ,note 5))
+(defmacro enotes/get-color (note) `(elt ,note 6))
+
+(defun enotes/set-event-time (note date) (aset note 0 date))
+(defun enotes/set-warning-time (note date) (aset note 1 date))
+(defun enotes/set-note-time (note date) (aset note 2 date))
+(defun enotes/set-title (note title) (aset note 3 (if (string= title "") "(No title)" title)))
+(defun enotes/set-ref (note ref) (aset note 4 ref))
+(defun enotes/set-info (note info) (aset note 5 (if (string= info "") nil info)))
+(defun enotes/set-color (note color) (aset note 6 (if (string= color "") nil color)))
+
+(defvar enotes/notes nil "Contains the list of notes")
+(defvar enotes/mode-map nil "Mode map for enotes/mode")
+
+(defvar enotes/past-history nil "Contains the history for undo")
+(defvar enotes/futur-history nil "Contains the history for redo")
+
+(defconst enotes/version "1.2" "The version Identifier")
+(defconst enotes/year-duration 31536000 "How many seconds in a year")
+(defconst enotes/month-duration 2592000 "How many seconds in a month")
+(defconst enotes/week-duration 604800 "How many seconds in a week")
+(defconst enotes/day-duration 86400 "How many seconds in a day")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Face definitions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defface enotes/list-title-face
+ '((((background light)) (:foreground "royal blue"))
+ (((background dark)) (:foreground "azure2")))
+ "The face for the list titles.")
+
+(defface enotes/alarm-face
+ '((((background light)) (:foreground "red3" :bold t))
+ (((background dark)) (:foreground "red" :bold t)))
+ "The face for the alarm titles.")
+
+(defface enotes/wrong-time-face
+ '((((background light)) (:foreground "red3" :bold t))
+ (((background dark)) (:foreground "red" :bold t)))
+ "The face for time in the past.")
+
+(defface enotes/wrong-warning-face
+ '((((background light)) (:foreground "orange3" :bold t))
+ (((background dark)) (:foreground "orange" :bold t)))
+ "The face for warning after the event.")
+
+(defface enotes/title-face
+ '((((background light)) (:underline t)))
+ "The face for event title.")
+
+(defface enotes/information-face
+ '((((background light)) (:foreground "gray50")))
+ "The face for the additional information.")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; (defun enotes/position-note (note)
+;; "Returns the position of note NOTE in buffer or nil if it can not be
+;; found"
+;; (let ((pos (point-min)))
+;; (while (and pos (not (eq note (get-text-property pos 'note))))
+;; (message "pos = %s note = %s" (prin1-to-string pos) (prin1-to-string (get-text-property pos 'note)))
+;; (setq pos (next-single-property-change pos 'note))
+;; )
+;; (if (and pos (eq note (get-text-property pos 'note))) pos nil)))
+
+(defun enotes/go-to-next-note ()
+ "Move the cursor to the next note in buffer"
+ (interactive)
+ (let ((next (next-single-property-change (point) 'note)))
+ (when (and next
+ (not (get-text-property next 'note)))
+ (setq next (next-single-property-change next 'note)))
+ (unless next
+ (setq next (next-single-property-change (point-min) 'note)))
+ (if next (goto-char next)
+ (goto-char (point-min)))))
+
+(defun enotes/go-to-prev-note ()
+ "Move the cursor to the previous note in buffer"
+ (interactive)
+ (let ((prev (previous-single-property-change (1- (point)) 'note)))
+ (when (and prev
+ (not (get-text-property prev 'note)))
+ (setq prev (previous-single-property-change prev 'note)))
+ (unless prev
+ (setq prev (previous-single-property-change (point-max) 'note)))
+ (if prev (goto-char prev)
+ (goto-char (point-max)))))
+
+(defun enotes/go-to-ref-at-point ()
+ "Go to the reference (file only at this moment) of the note at cursor's location"
+ (interactive)
+ (let ((note (get-text-property (point) 'note)))
+ (if (not note) (error "No note at point")
+ (let ((ref (enotes/get-ref note)))
+ (if (not ref) (error "No reference")
+ (cond ((equal (car ref) 'file)
+ (switch-to-buffer (find-file-noselect (car (cdr ref))))
+ (goto-char (car (cddr ref))))
+ (t (error "Unknown attachement"))))))))
+
+(defun enotes/add-file-note ()
+ "Add a note with a reference to the visited file"
+ (interactive)
+ (let ((date (format-time-string enotes/input-time-format (time-add (current-time) `(0 ,enotes/day-duration 0))))
+ (file (buffer-file-name)))
+ (if (not file)
+ (error "You are not visiting a file")
+ (enotes/add-note date "Going on working" (list 'file file (point))))))
+
+(defun enotes/round-time (time delay)
+ "Heuristic to round the given time according to how far away it is
+in the futur"
+ (cond ((> delay enotes/month-duration) (+ 25200 (- time (mod time enotes/day-duration))))
+ ((> delay enotes/day-duration) (- time (mod time 3600)))
+ ((> delay 11400) (- time (mod time 900)))
+ ((> delay 1800) (- time (mod time 300)))
+ ((> delay 300) (- time (mod time 60)))
+ (t (fround time))))
+
+(defun enotes/next-in-list (x l)
+ (if x
+ (if (equal x (car l)) (car (cdr l))
+ (and l (enotes/next-in-list x (cdr l))))
+ (car l)))
+
+(defun enotes/next-color ()
+ "Change the color mark of the event at point"
+ (interactive)
+ (let* ((note (get-text-property (point) 'note))
+ (color (and note (enotes/get-color note))))
+ (when note
+ (enotes/store-for-undo)
+ (enotes/set-color note (enotes/next-in-list color enotes/color-list))
+ (enotes/do-it))))
+
+(defun enotes/move-warning (change)
+ "Move the next warning 24 hours in the futur"
+ (interactive)
+ (let* ((note (get-text-property (point) 'note))
+ (time (float-time))
+ (event-time (enotes/get-event-time note))
+ (warning-time (enotes/get-warning-time note))
+ (new-warning-time (+ change warning-time)))
+ (enotes/store-for-undo)
+ (if (and (< warning-time event-time) (> new-warning-time event-time))
+ (enotes/set-warning-time note event-time)
+ (enotes/set-warning-time note new-warning-time)))
+ (enotes/do-it))
+
+(defun enotes/move-warning-1h ()
+ "Move the next warning one hour in the futur"
+ (interactive)
+ (enotes/move-warning 3600))
+
+(defun enotes/move-warning-24h ()
+ "Move the next warning 24 hours in the futur"
+ (interactive)
+ (enotes/move-warning enotes/day-duration))
+
+(defun enotes/move-event (change)
+ "Move the event date itself"
+ (interactive)
+ (let* ((note (get-text-property (point) 'note))
+ (event-time (and note (enotes/get-event-time note)))
+ (new-event-time (and event-time (+ change event-time))))
+ (when note
+ (enotes/store-for-undo)
+ (enotes/set-event-time note new-event-time)
+ (enotes/set-refresh-warning-time note)
+ (enotes/do-it))))
+
+(defun enotes/move-event-24h ()
+ "Move the event date itself 24 hours in the futur"
+ (interactive)
+ (enotes/move-event enotes/day-duration))
+
+(defun enotes/move-event-1h ()
+ "Move the event date itself one hour in the futur"
+ (interactive)
+ (enotes/move-event 3600))
+
+(defun enotes/set-refresh-warning-time (note)
+ "Compute a new warning date, according to the event date, the note
+creating date and the current next warning. This is an ad-hoc
+heuristic. Improvements are welcome"
+
+ (if (enotes/get-warning-time note)
+
+ ;; If it's not the first warning, we compute it as a delay from
+ ;; now
+
+ (let* ((time (float-time))
+ (event-time (enotes/get-event-time note))
+ (warning-time (enotes/get-warning-time note))
+ (note-time (enotes/get-note-time note))
+ (anticipation (- event-time note-time))
+ (delay (- event-time time))
+ (delay-warning
+
+ (cond
+ ((> anticipation enotes/year-duration)
+ ;; The note was set more than ONE YEAR before the
+ ;; event (serious stuff!)
+ (cond ((> delay (* 2 enotes/month-duration)) enotes/month-duration)
+ ((> delay (* 2 enotes/week-duration)) enotes/week-duration)
+ (t enotes/day-duration)))
+
+ ((> anticipation enotes/month-duration)
+ ;; The note was set at least one month before the
+ ;; event
+ (cond ((> delay enotes/week-duration) (* 2 enotes/day-duration))
+ (t enotes/day-duration)))
+
+ ((> anticipation enotes/week-duration)
+ ;; The note was set at least one week before the event
+ (cond ((> delay enotes/day-duration) enotes/day-duration)
+ (t 3600)))
+
+ (t
+ (cond ((> delay enotes/day-duration) enotes/day-duration)
+ ((> delay 1800) 1800)
+ (t 900)))
+
+ ))
+
+ (new-warning-time (enotes/round-time (+ time delay-warning) delay)))
+
+ ;; If the preceding warning was before the event and the new
+ ;; is after, force the new at the event date
+
+ (if (and (< warning-time event-time) (> new-warning-time event-time))
+ (enotes/set-warning-time note event-time)
+ ;; else let the new be where we computed
+ (enotes/set-warning-time note new-warning-time)))
+
+ ;; If it's the first warning, we define how long before the event
+ ;; it has to be set
+
+ (let* ((time (fround (float-time)))
+ (anticipation (- (enotes/get-event-time note) (enotes/get-note-time note)))
+ (delay-warning
+ (cond
+ ((> anticipation enotes/year-duration) (* 2 enotes/month-duration))
+ ((> anticipation enotes/month-duration) enotes/week-duration)
+ ((> anticipation enotes/week-duration) (* 2 enotes/day-duration))
+ ((> anticipation (* 2 enotes/day-duration)) enotes/day-duration)
+ (t 3600)
+ ))
+ (delay-warning (- (- (enotes/get-event-time note) delay-warning) time)))
+
+ ;; Force at least 60s in the future
+
+ (enotes/set-warning-time
+ note
+ (max (+ time 60)
+ (enotes/round-time (+ time delay-warning) delay-warning))))
+ )
+ )
+
+(defun enotes/add-note (&optional date title ref info)
+ "Add a note and ask for the field values if they are not provided"
+ (interactive)
+
+ (let* ((title (read-from-minibuffer
+ "Title: "
+ (or title "")))
+ (date (read-from-minibuffer
+ "Date: "
+ (or date
+ (format-time-string enotes/input-time-format
+ (current-time)))))
+ (info "")
+ (new-note (vector (enotes/string-to-float-time date)
+ nil
+ (fround (float-time))
+ nil
+ ref
+ (if (string= info "") nil info)
+ nil)))
+
+ (enotes/set-title new-note title)
+ (enotes/set-refresh-warning-time new-note)
+
+ (enotes/store-for-undo)
+
+ (setq enotes/notes (cons new-note enotes/notes))
+ (enotes/save-notes)
+ (enotes/do-it)
+ ;; (message "%s (%s)" (prin1-to-string new-note) (prin1-to-string (enotes/position-note new-note)))
+ ))
+
+(defun enotes/default-list (l default-l)
+ (when l (cons (or (car l) (car default-l)) (enotes/default-list (cdr l) (cdr default-l)))))
+
+(defun enotes/string-to-float-time (date)
+ (let ((time (decode-time (current-time))))
+ (float-time (apply 'encode-time
+ (enotes/default-list (parse-time-string date) `(0 0 6 1 ,(elt time 4) ,(elt time 5)))))))
+
+(defun enotes/second-to-delay (second)
+ "Returns a string describing a delay in english"
+ (cond ((< second (- enotes/day-duration)) (format "%d day%s ago" (/ second -86400) (if (> (ftruncate (/ second -86400)) 1) "s" "")))
+ ((< second -3600) (format "%dh ago" (/ second -3600)))
+ ((< second -300) (format "%dmin ago" (/ second -60)))
+ ((< second 0) (format "now!!!" (/ second -60)))
+ ((< second 3600) (format "in %dmin" (/ second 60)))
+ ((< second enotes/day-duration) (format "in %dh" (/ second 3600)))
+ ((< second enotes/month-duration) (format "in %d day%s" (/ second 86400) (if (> (ftruncate (/ second 86400)) 1) "s" "")))
+ (t (format "in ~ %d month%s" (/ second 2592000) (if (> (ftruncate (/ second 2592000)) 1) "s" "")))))
+
+(defun enotes/cond-propertize (cnd str prop)
+ "Propertize STR if both CND and PROP are non-nil"
+ (if (and prop cnd) (apply 'propertize (cons str prop))
+ str))
+
+(defun enotes/title-string (note)
+ (concat
+
+ (propertize
+
+ (concat
+ " "
+
+ ;; The small color tag
+
+ (if (enotes/get-color note)
+ (propertize " " 'face (cons 'background-color
+ (enotes/get-color note)))
+ " ")
+
+ " ")
+
+ 'field 'title)
+
+ (propertize
+ (enotes/get-title note)
+ 'face 'enotes/title-face
+ 'field 'title)
+
+ (if (and (not enotes/full-display) (enotes/get-info note)) (propertize " /.../" 'field 'information) "")
+
+ ))
+
+(defun enotes/insert-blank-line () (interactive)
+ (let ((p (point)))
+ (unless (and
+ (> p 1)
+ (eq (char-before p) ?\n)
+ (or (eq p 2)
+ (eq (char-before (1- p)) ?\n)))
+ (insert "\n"))))
+
+(defun enotes/insert-note (note time)
+ "Insert the note in the buffer, with fields properties so that we can
+edit them easily later on"
+ (let ((obsolete (>= time (enotes/get-event-time note)))
+ (info (enotes/get-info note))
+ (title (enotes/title-string note)))
+
+ (when enotes/full-display (enotes/insert-blank-line))
+
+ (insert
+ (propertize
+ (concat
+
+ ;; Title
+
+ title
+
+ (if enotes/full-display "\n"
+ (make-string (max 0 (- 40 (length title))) ? )
+ )
+
+ ;; Date event
+
+ (propertize
+ (concat
+ (if enotes/full-display " Date: " " ")
+ (enotes/cond-propertize
+ obsolete
+ (format-time-string enotes/time-format (seconds-to-time (enotes/get-event-time note)))
+ '(face enotes/wrong-time-face))
+ " ("
+ (enotes/second-to-delay (- (enotes/get-event-time note) time))
+ ")\n")
+ 'field 'event-time)
+
+ ;; Date next warning
+
+ (when (and enotes/full-display
+ (not (equal (enotes/get-warning-time note) (enotes/get-event-time note))))
+ (propertize
+ (concat
+ " Warning: "
+ (enotes/cond-propertize
+ (and (not obsolete) (> (enotes/get-warning-time note) (enotes/get-event-time note)))
+ (format-time-string enotes/time-format (seconds-to-time (enotes/get-warning-time note)))
+ '(face enotes/wrong-warning-face))
+ "\n"
+ )
+ 'field 'warning-time)
+ )
+
+ ;; Reference (if there is one)
+
+ (let ((ref (enotes/get-ref note)))
+ (when ref
+ (cond ((equal 'file (car ref))
+ (format " Ref: file [%s]\n" (file-name-nondirectory (car (cdr ref)))))
+ (t " Ref: *unknown type*\n"))))
+
+ ;; Complementary information (if there are some)
+
+ (when (and enotes/full-display info)
+ (propertize
+ (format " Info: %s\n"
+ (propertize
+ ;; Ugly hack to match exactly the end of
+ ;; the string: add a ^_ at the end ...
+ (replace-regexp-in-string "[\n ]*\1f" ""
+ (replace-regexp-in-string "\n\\([^\n]+\\)"
+ "\n \\1"
+ (concat info "\1f")))
+ 'face 'enotes/information-face)
+ )
+ 'field 'information)
+ )
+
+ )
+
+ 'note note 'obsolete obsolete))))
+
+(defun enotes/delete-note-at-point ()
+ "Delete the note at cursor's location"
+ (interactive)
+ (let ((note (get-text-property (point) 'note)))
+ (if (not note) (error "No note at point")
+ (enotes/store-for-undo)
+ (setq enotes/notes (delq note enotes/notes))))
+ (enotes/do-it))
+
+(defun enotes/set-warning-at-event ()
+ "Force the next warning time at the event time"
+ (interactive)
+ (let ((time (float-time))
+ (note (get-text-property (point) 'note)))
+ (if (not note) (error "No note at point")
+ (let ((obsolete (>= time (enotes/get-event-time note))))
+ (enotes/store-for-undo)
+ (if obsolete
+ (enotes/set-warning-time note (+ time 3600))
+ (enotes/set-warning-time note (enotes/get-event-time note))))
+ (enotes/do-it))))
+
+(defun enotes/switch-help () (interactive)
+ (setq enotes/show-help (not enotes/show-help))
+ (enotes/do-it))
+
+(defun enotes/switch-infos-display ()
+ "Switch between displaying and not displaying the warning time
+and additional information"
+ (interactive)
+ (setq enotes/full-display (not enotes/full-display))
+ (enotes/do-it))
+
+(defun enotes/switch-display () (interactive)
+
+ (setq enotes/display-mode
+ (cdr (assoc
+ enotes/display-mode
+ '((enotes/insert-all-notes-by-delay . enotes/insert-all-notes-by-week)
+ (enotes/insert-all-notes-by-week . enotes/insert-all-notes-by-delay)))))
+
+ (enotes/do-it))
+
+(defun enotes/save-note-information () (interactive)
+ (enotes/store-for-undo)
+ (enotes/set-info enotes/edited-note
+ (buffer-substring-no-properties (point-min)
+ (point-max)))
+ (kill-this-buffer)
+ (enotes/do-it))
+
+(defun enotes/cancel-edit-info () (interactive)
+ (if (and (buffer-modified-p)
+ (not (y-or-n-p "Lose changes ? ")))
+ (error "Cancel cancel"))
+
+ (kill-this-buffer)
+ (enotes/do-it)
+ (message "Cancel")
+ )
+
+(defun enotes/edit-information-note-at-point ()
+ "Use the 'field property of the character at point to figure out
+what note has to have its information edited, and edit it in a new
+buffer"
+
+ (interactive)
+ (let ((note (get-text-property (point) 'note))
+ (map (make-sparse-keymap)))
+
+ (unless note (error "No note at point"))
+
+ (switch-to-buffer (get-buffer-create
+ (generate-new-buffer-name "*enotes information*")))
+
+ (text-mode)
+ (auto-fill-mode)
+
+ (define-key map [(control c) (control c)] 'enotes/save-note-information)
+ (define-key map [(control c) (control q)] 'enotes/cancel-edit-info)
+
+ (set (make-local-variable 'enotes/edited-note) note)
+ (set (make-local-variable 'fill-column) 60)
+
+ (use-local-map map)
+ (when (enotes/get-info note)
+ (insert (enotes/get-info note))
+ (setq buffer-undo-list nil)
+ (set-buffer-modified-p nil)
+ (set-auto-mode))
+
+ (message "C-c C-c to save the information, C-c C-q to cancel")
+
+ ))
+
+(defun enotes/edit-event-time-note-at-point ()
+ (interactive)
+ (let ((note (get-text-property (point) 'note)))
+
+ (unless note (error "No note at point"))
+
+ (let ((new-event-time (enotes/string-to-float-time
+ (read-from-minibuffer
+ "Date: "
+ (format-time-string
+ enotes/input-time-format
+ (seconds-to-time (enotes/get-event-time note)))))))
+ (unless (= new-event-time (enotes/get-event-time note))
+ (enotes/store-for-undo)
+ (enotes/set-event-time note new-event-time)
+ (enotes/do-it)))))
+
+(defun enotes/edit-warning-time-note-at-point ()
+ (interactive)
+ (let ((note (get-text-property (point) 'note)))
+
+ (unless note (error "No note at point"))
+
+ (let ((new-warning-time (enotes/string-to-float-time
+ (read-from-minibuffer
+ "Warning: "
+ (format-time-string
+ enotes/input-time-format
+ (seconds-to-time (enotes/get-warning-time note)))))))
+ (unless (= new-warning-time (enotes/get-warning-time note))
+ (enotes/store-for-undo)
+ (enotes/set-warning-time note new-warning-time)
+ (enotes/do-it)))))
+
+(defun enotes/edit-field-at-point ()
+ "Ask for a new value for the field at cursor's location"
+ (interactive)
+
+ (let ((note (get-text-property (point) 'note))
+ (field (get-text-property (point) 'field)))
+
+ (cond
+
+ ((eq field 'title)
+ (let ((new-title (read-from-minibuffer "Title: " (enotes/get-title note))))
+ (unless (string= new-title (enotes/get-title note))
+ (enotes/store-for-undo)
+ (enotes/set-title note new-title)
+ (enotes/do-it))))
+
+ ((eq field 'event-time)
+ (let ((new-event-time (enotes/string-to-float-time
+ (read-from-minibuffer
+ "Date: "
+ (format-time-string
+ enotes/input-time-format
+ (seconds-to-time (enotes/get-event-time note)))))))
+ (unless (= new-event-time (enotes/get-event-time note))
+ (enotes/store-for-undo)
+ (enotes/set-event-time note new-event-time)
+ (enotes/set-refresh-warning-time note)
+ (enotes/do-it))))
+
+ ((eq field 'note-time)
+ (error "Can not edit that field"))
+
+ ((eq field 'warning-time)
+ (let ((new-warning-time (enotes/string-to-float-time
+ (read-from-minibuffer
+ "Warning: "
+ (format-time-string
+ enotes/input-time-format
+ (seconds-to-time (enotes/get-warning-time note)))))))
+ (unless (= new-warning-time (enotes/get-warning-time note))
+ (enotes/store-for-undo)
+ (enotes/set-warning-time note new-warning-time)
+ (enotes/do-it))))
+
+ ((eq field 'information)
+ (enotes/edit-information-note-at-point))
+
+ (t (error "No known field at point"))
+
+ )
+ )
+ )
+
+(defun enotes/remove-buffer ()
+ "Kill the current buffer and delete the current window if it's not
+the only one in the frame"
+ (interactive)
+ (kill-this-buffer)
+ (unless (one-window-p t) (delete-window)))
+
+(defun enotes/remove-obsolete-remove-buffer ()
+ "Delete the obsolete notes appearing in the current buffer, delete
+the buffer and the current window if it's not the only one in the
+frame"
+ (interactive)
+
+ (let ((s (point-min)))
+ (while (setq s (text-property-any (1+ s) (point-max) 'obsolete t))
+ (setq enotes/notes (delq (get-text-property s 'note) enotes/notes))))
+
+ ;; If the "list of notes" buffer is visible and is not the current
+ ;; one, refresh it
+
+ (enotes/remove-buffer)
+ (enotes/do-it))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; The undo/redo stuff
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun enotes/store-for-undo ()
+ "Keep a copy of the current `enotes/notes' in `enotes/past-history'
+value for undo. Reset `enotes/futur-history' to nil"
+ (interactive)
+ ;; Need to copy the cells themselves, thus the mapcar thingy
+ (setq enotes/past-history (cons (mapcar 'copy-sequence enotes/notes) enotes/past-history)
+ enotes/futur-history nil)
+ )
+
+(defun enotes/undo ()
+ "Put the current `enotes/notes' into `enotes/futur-history' and take
+the value of `enotes/notes' from `enotes/past-history'"
+ (interactive)
+ (if (not enotes/past-history)
+ (error "Nothing to undo!")
+ (setq enotes/futur-history (cons enotes/notes enotes/futur-history)
+ enotes/notes (car enotes/past-history)
+ enotes/past-history (cdr enotes/past-history))
+ (enotes/refresh-note-buffer (float-time) t)
+ (message "Undo!"))
+ )
+
+(defun enotes/redo ()
+ "Put the current `enotes/notes' into `enotes/past-history' and take
+the value of `enotes/notes' from `enotes/futur-history'"
+ (interactive)
+ (if (not enotes/futur-history)
+ (error "Nothing to redo!")
+ (setq enotes/past-history (cons enotes/notes enotes/past-history)
+ enotes/notes (car enotes/futur-history)
+ enotes/futur-history (cdr enotes/futur-history))
+ (enotes/refresh-note-buffer (float-time) t)
+ (message "Redo!"))
+ )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun enotes/mode ()
+ "Major mode to manage a list of notes. The list of 'notes' is kept
+in `enotes/notes'. Each note is defined by a date, an event time, a
+warning time and optionally by a string of informations and a colored
+tag. Just call `enotes/init' to load the notes saved during the last
+session and run the whole stuff. The notes are saved when a note is
+added or when emacs is killed.
+
+You can bring the main buffer containing all notes by calling
+`enotes/show-all-notes'."
+
+ (interactive)
+
+ (unless enotes/mode-map
+ (setq enotes/mode-map (make-sparse-keymap))
+ (suppress-keymap enotes/mode-map)
+ (mapc (lambda (x) (define-key enotes/mode-map (car x) (cdr x)))
+ `(([(delete)] . enotes/delete-note-at-point)
+ ([(control d)] . enotes/delete-note-at-point)
+ ("d" . enotes/edit-event-time-note-at-point)
+ ("a" . enotes/add-note)
+ ("e" . enotes/edit-field-at-point)
+ ("h" . enotes/switch-help)
+ ("m" . enotes/switch-display)
+ ("I" . enotes/switch-infos-display)
+ ("i" . enotes/edit-information-note-at-point)
+ ("w" . enotes/edit-warning-time-note-at-point)
+ ("c" . enotes/next-color)
+ ("g" . enotes/go-to-ref-at-point)
+ ("t" . enotes/move-warning-24h)
+ ("T" . enotes/move-event-24h)
+ ("=" . enotes/move-warning-1h)
+ ("+" . enotes/move-event-1h)
+ (,(kbd "RET") . enotes/go-to-ref-at-point)
+ (,(kbd "TAB") . enotes/go-to-next-note)
+ ("n" . enotes/go-to-next-note)
+ ([(shift iso-lefttab)] . enotes/go-to-prev-note)
+ ("p" . enotes/go-to-prev-note)
+ ("q" . enotes/remove-buffer)
+ ("Q" . enotes/remove-obsolete-remove-buffer)
+ ("u" . enotes/undo)
+ ("r" . enotes/redo)
+ ("s" . enotes/save-notes)
+ ([(control x) (control s)] . enotes/save-notes)
+ ("f" . enotes/set-warning-at-event)
+ ))
+
+ (substitute-key-definition 'undo 'enotes/undo enotes/mode-map global-map)
+ )
+
+ (kill-all-local-variables)
+
+ (use-local-map enotes/mode-map)
+
+ (setq mode-name "Enotes"
+ buffer-read-only t
+ ;; truncate-lines t
+ major-mode 'enotes/mode)
+ )
+
+(defun enotes/list-of-notes-in-buffer ()
+ "Return all the notes in the current buffer (used to refresh them)"
+ (let ((current (point-min))
+ (result ()))
+ (while (setq current (next-single-property-change current 'note))
+ (when current
+ (let ((n (get-text-property current 'note)))
+ (if (and n (member n enotes/notes)) (setq result (cons n result))))))
+ result))
+
+(defun enotes/line-title (title)
+ "Create a string of length 75 padded with -s"
+ (concat "-- " title " "
+ (make-string (- 72 (length title)) ?-)
+ ;; "\n"
+ ;; (if enotes/full-display "" "\n")
+ )
+ )
+
+(defun enotes/sorted-by-time (notes)
+ (sort (copy-sequence notes)
+ (lambda (n1 n2) (and (<= (enotes/get-event-time n1)
+ (enotes/get-event-time n2))
+ (or (not (= (enotes/get-event-time n1)
+ (enotes/get-event-time n2)))
+ (string< (enotes/get-title n1)
+ (enotes/get-title n2)))))))
+
+;; Show all notes one after another, sorted by event date. A title is
+;; inserted for each week of the year containing events, and for each
+;; month.
+
+(defun enotes/insert-all-notes-by-week (time notes-to-display)
+ "Inserts notes grouped by weeks."
+ (let ((current-week (format-time-string "%W" (seconds-to-time time)))
+ (current-year (format-time-string "%Y" (seconds-to-time time)))
+ (next-week (format-time-string "%W" (seconds-to-time (+ time enotes/week-duration))))
+ (loop-week "")
+ (loop-month "")
+ (loop-year "")
+ (already-added-blank))
+
+ (mapc (lambda (note)
+
+ (let* ((time-event (seconds-to-time (enotes/get-event-time note)))
+ (week (format-time-string "%W" time-event))
+ (month (format-time-string "%B" time-event))
+ (year (format-time-string "%Y" time-event)))
+
+ (when (not (and (string= month loop-month) (string= year loop-year)))
+ (setq loop-month month
+ loop-year year)
+ (insert "\n"
+ (propertize (enotes/line-title
+ (concat month
+ (if (not (string= year current-year))
+ (concat " (" year ")"))
+ ))
+ 'face 'enotes/list-title-face)
+ "\n"
+ )
+ (insert "\n")
+ (setq already-added-blank t)
+ )
+
+ (when (not (string= week loop-week))
+ (setq loop-week week)
+ (unless already-added-blank (insert "\n"))
+ (insert (propertize (concat " Week " week
+ (when (string= year current-year)
+ (if (string= week current-week) " (current)"))
+ (when (string= year current-year)
+ (if (string= week next-week) " (next week)"))
+ "\n")
+ 'face 'enotes/list-title-face)
+ )
+
+ (unless enotes/full-display
+ (insert "\n")
+ )
+ )
+ )
+
+ (setq already-added-blank nil)
+ (enotes/insert-note note time))
+
+ (enotes/sorted-by-time notes-to-display)
+ )
+ ))
+
+;; Show all notes one after another, sorted by event date. A title is
+;; inserted for "in a day or more", "in a week or more", etc.
+
+(defun enotes/insert-all-notes-by-delay (time notes-to-display)
+ "Inserts all notes of the current day, then those less than one week
+in the futur, then those less than one month (30 days) in the futur."
+ (let ((delay 0))
+ (mapc (lambda (note)
+ (let ((s (cond
+ ((and (< delay enotes/year-duration)
+ (>= (- (enotes/get-event-time note) time) enotes/year-duration))
+ (enotes/line-title "In a year or more"))
+
+ ((and (< delay enotes/month-duration)
+ (>= (- (enotes/get-event-time note) time) enotes/month-duration))
+ (enotes/line-title "In a month or more"))
+
+ ((and (< delay enotes/week-duration)
+ (>= (- (enotes/get-event-time note) time) enotes/week-duration))
+ (enotes/line-title "In a week or more"))
+
+ ((and (< delay enotes/day-duration)
+ (>= (- (enotes/get-event-time note) time) enotes/day-duration))
+ (enotes/line-title "In a day or more")))))
+
+ (when s (insert "\n" (propertize s 'face 'enotes/list-title-face) "\n\n")))
+
+ (setq delay (- (enotes/get-event-time note) time))
+ (enotes/insert-note note time))
+
+ (enotes/sorted-by-time notes-to-display)
+ )
+ )
+ )
+
+(defun enotes/refresh-note-buffer (time force-all)
+
+ "Refresh the current buffer as the buffer containing the list of
+notes. If FORCE-ALL is true display all notes, do not only update
+those in the buffer"
+
+ ;; This is sort of ugly, we keep track of where we are, to be able
+ ;; to put back the cursor at the same location (at least the same
+ ;; note and field, or the position itself), even after massive
+ ;; modifications
+
+ (let ((note (get-text-property (point) 'note))
+ (field (get-text-property (point) 'field))
+ (p (point))
+ (inhibit-read-only t)
+ (notes-to-display (if force-all enotes/notes (enotes/list-of-notes-in-buffer))))
+
+ (erase-buffer)
+
+ (when enotes/show-help
+ (insert "\n"
+ enotes/help-string "\n")
+ )
+
+ ;; Display all note according to the enotes/display-mode variable.
+
+ (if enotes/notes
+ (eval `(,enotes/display-mode time notes-to-display))
+ (insert "\n "
+ (propertize "No note." 'face 'bold)
+ " (call enotes/init to load the saved ones).\n"))
+
+ (enotes/mode)
+
+ ;; Try to go back where we were, if we can't, go to the point
+ ;; where we were (a priori lame but convenient in practice)
+
+ (let* ((s1 (text-property-any (point-min) (point-max) 'note note))
+ (s2 (and s1 (text-property-any s1 (point-max) 'field field))))
+ (if s2 (goto-char s2) (goto-char p))
+ ;; (recenter)
+ )
+ ))
+
+;; Switches to the note list buffer and refresh it
+
+(defun enotes/show-all-notes (&optional current-window)
+ "Show all notes in a buffer for edition"
+ (interactive "P")
+ (let ((buf (get-buffer "*enotes*")))
+ (if current-window
+ (switch-to-buffer (get-buffer-create "*enotes*"))
+ (switch-to-buffer-other-window (get-buffer-create "*enotes*")))
+ (enotes/refresh-note-buffer (float-time) t)))
+
+(defun enotes/show-alarms (time)
+ "Add the new alarms to the alarm buffer"
+
+ ;; I have to say, I am not sure to understand what
+ ;; with-output-to-temp-buffer does ...
+
+ (with-output-to-temp-buffer "*enotes alarms*"
+ (set-buffer "*enotes alarms*")
+
+ (insert
+ "\n"
+ (propertize
+ (format " Alarms (%s)" (format-time-string "%a %b %d %H:%M" (current-time)))
+ 'face 'enotes/alarm-face)
+ "\n"
+ )
+
+ (when enotes/show-help
+ (insert "\n"
+ (propertize (enotes/line-title "Help") 'face 'enotes/list-title-face)
+ "\n\n" enotes/help-string "\n")
+ )
+
+ (mapc (lambda (note)
+ (when (>= time (enotes/get-warning-time note))
+ (enotes/set-refresh-warning-time note)
+ (enotes/insert-note note time)))
+ enotes/notes)
+
+ (enotes/mode)
+
+ (resize-temp-buffer-window))
+
+ (run-hooks 'enotes/alarm-hook)
+ )
+
+(defun enotes/do-it ()
+
+ "Refresh all buffers in enotes/mode and forces all notes to be
+visible in the main one (called *enotes*). Generates an alarm with the
+notes whose warnings are in the past, refresh their warning
+times. Sets a call for the soonest one in the future."
+
+ (let ((time (float-time)))
+
+ ;; Refresh all notes in all enotes buffers
+ (mapc (lambda (buf)
+ (set-buffer buf)
+ (when (eq major-mode 'enotes/mode)
+ (enotes/refresh-note-buffer time (string= (buffer-name) "*enotes*"))))
+ (buffer-list))
+
+ (setq enotes/notes (sort enotes/notes
+ (lambda (n1 n2) (< (enotes/get-warning-time n1)
+ (enotes/get-warning-time n2)))))
+
+ ;; If there is at least one to be shown, show them all
+ (when (and enotes/notes (>= time (enotes/get-warning-time (car enotes/notes))))
+ (save-excursion (enotes/show-alarms time)))
+
+ ;; If still something in the pipe, set a call for the next time
+ (when enotes/notes
+ (run-at-time (1+ (max 0 (- (enotes/get-warning-time (car enotes/notes)) (float-time))))
+ nil
+ 'enotes/do-it))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Saving and loading
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun enotes/remove-properties-in-place (l)
+ (if (stringp l) (set-text-properties 0 (length l) nil l)
+ (when (and l (listp l))
+ (enotes/remove-properties-in-place (car l))
+ (enotes/remove-properties-in-place (cdr l)))))
+
+(defun enotes/save-notes ()
+ "Write down in the file specified by `enotes/file' the content of
+`enotes/notes'"
+ (interactive)
+
+ ;; There should not be properties in the strings. However, we strip
+ ;; them out before saving for more safety.
+
+ (enotes/remove-properties-in-place enotes/notes)
+
+ (with-temp-buffer
+
+ ;; We trust the automatic detection of the appropriate encoding
+ ;; scheme
+
+ ;; (set-buffer-file-coding-system 'latin-1)
+
+ (set-visited-file-name enotes/file)
+
+ (insert ";; -*-Emacs-Lisp-*-\n\n"
+ ";; Saved by enotes.el on "
+ (format-time-string "%h %a %d %Y %H:%M:%S" (seconds-to-time (float-time)))
+ ".\n"
+ ";; Automatically generated, edit with care.\n"
+ "\n"
+ "(setq enotes/notes\n")
+
+ (if (not enotes/notes) (insert "()\n")
+ (insert "'(\n")
+ ;; We manage to have one note per line, so that it is handled
+ ;; correctly by CVS & co. (this is slightly messed-up if you
+ ;; have CRs in the information field)
+ (mapcar (lambda (entry) (insert (concat (prin1-to-string entry) "\n"))) enotes/notes)
+ (insert ")\n"))
+
+ (insert ")\n")
+ (emacs-lisp-mode)
+ (indent-region (point-min) (point-max) nil)
+ ;; save-buffer ensures the creation of the backup files if
+ ;; necessary
+ (save-buffer))
+
+ (let ((buf (get-buffer "*enotes*")))
+ (when buf
+ (set-buffer buf)
+ (set-buffer-modified-p nil)))
+
+ (message "Notes saved in %s" enotes/file)
+
+ )
+
+(defun enotes/load-notes ()
+
+ "Load the notes from the file specified by `enotes/file' into `enotes/notes'"
+
+ (if (file-exists-p enotes/file)
+ ;; This hack to handle the old variable name enotes-notes
+ (let ((enotes-notes nil))
+ (load enotes/file)
+ (when (and (not enotes/notes)
+ enotes-notes)
+ (setq enotes/notes enotes-notes)))
+ (setq enotes/notes ())
+ (message "Creating a new list of notes. Welcome on board!"))
+
+ ;; Fix the length of notes to the current length (i.e. add as many
+ ;; fields as required to be compliant with the current version)
+
+ (setq enotes/notes
+ (mapcar (lambda (x) ()
+ (apply 'vector (append x (make-list (- 7 (length x)) nil))))
+ enotes/notes))
+
+ ;; If there are events in the past, let's use their date as the
+ ;; warning-time date
+
+ ;; (mapc (lambda (note)
+ ;; (if (> (float-time) (enotes/get-event-time note))
+ ;; (enotes/set-event-time note (enotes/get-event-time note))))
+ ;; enotes/notes)
+
+ (enotes/do-it))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; The main routine to start all that stuff
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun enotes/init (&optional with-what)
+ "Loads the notes from the file specified in `enotes/file' and calls
+`enotes/do-it'."
+ (interactive)
+
+ (add-hook 'kill-emacs-hook 'enotes/save-notes)
+
+ (enotes/load-notes))
+
+;; (when (and (memq 'gnus with-what)
+;; (require 'gnus-sum nil t))
+
+;; (defun enotes/add-gnus-note ()
+;; "Add a note with a reference to a mail"
+;; (interactive)
+;; (let ((from
+;; (save-window-excursion
+;; (gnus-setup-message 'reply
+;; (gnus-summary-select-article)
+;; (set-buffer (gnus-copy-article-buffer))
+;; (gnus-msg-treat-broken-reply-to))
+;; (and (re-search-forward "^From: \\(.*\\)$")
+;; (match-string-no-properties 1))))
+;; (date (format-time-string enotes/input-time-format (time-add (current-time) '(0 86400 0)))))
+;; (when from (enotes/add-note date (concat "Reply to " from)))))
+;; (define-key enotes/mode-map "m" 'gnus-summary-mail-other-window)
+;; (define-key 'gnus-summary-mark-map "a" 'enotes/add-gnus-note)
+;; )
+
+;; (when (and (memq 'calendar with-what)
+;; (require 'parse-time nil t)
+;; (require 'calendar nil t))
+
+;; (defun enotes/show-calendar ()
+;; (interactive)
+;; (let ((note (get-text-property (point) 'note)))
+;; (if (not note) (message "No note at point")
+;; (calendar-goto-date (format-time-string
+;; "%h %a %d %Y %H:%M:%S"
+;; (seconds-to-time (enotes/get-event-time note)))))))
+;; )
--- /dev/null
+;; -*-Emacs-Lisp-*-
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; This program is free software; you can redistribute it and/or ;;
+;; modify it under the terms of the GNU General Public License as ;;
+;; published by the Free Software Foundation; either version 3, or (at ;;
+;; your option) any later version. ;;
+;; ;;
+;; This program is distributed in the hope that it will be useful, but ;;
+;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;
+;; General Public License for more details. ;;
+;; ;;
+;; You should have received a copy of the GNU General Public License ;;
+;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;
+;; ;;
+;; Written by and Copyright (C) Francois Fleuret ;;
+;; Contact <francois@fleuret.org> for comments & bug reports ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; This handy function calls the dict unix command.
+;;
+;; I put in my ~/.emacs.el
+;;
+;; (when (load "lookup-dict" t)
+;; (define-key global-map [(control \?)] 'lookup-dict))
+;;
+;; On Debian, install the package dict, and to use it without
+;; connection install dictd, dict-foldoc, dict-gcide, dict-jargon and
+;; dict-wn
+
+(defun lookup-dict (&optional force)
+
+ "Gets definitions with the unix 'dict' command. Takes for word
+either -- in this order, if possible -- the region, the word at
+point, and a word given interactively. An optional universal
+argument \\[universal-argument] forces the third."
+
+ (interactive "P")
+
+ (let ((word (or
+
+ ;; Word given as parameter
+ (and force "")
+
+ ;; Region (Emacs 23 has region-active-p)
+ (if (functionp 'region-active-p)
+ (and (region-active-p)
+ (buffer-substring (region-beginning) (region-end)))
+ (condition-case nil
+ (buffer-substring (region-beginning) (region-end))
+ (error nil)))
+
+ ;; Word at point
+ (thing-at-point 'word)
+
+ )))
+
+ (when (string= word "") (setq word (read-input "Word: ")))
+
+ (setq word (replace-regexp-in-string "[^a-zA-Z\- ]" "" (or word "")))
+
+ (let ((name (concat "*definition " word "*")))
+
+ (if (get-buffer name) (switch-to-buffer name)
+
+ (switch-to-buffer (generate-new-buffer name))
+
+ (text-mode)
+
+ (let ((map (make-sparse-keymap)))
+
+ (suppress-keymap map)
+ (define-key map "q" 'kill-this-buffer)
+ (define-key map (kbd "RET") 'lookup-dict)
+ (define-key map " " (lambda () (interactive)
+ (when (condition-case nil (scroll-up) (error t))
+ (beginning-of-buffer))))
+ (use-local-map map))
+
+ (insert "\nPress <space> to go one page down, <enter> to lookup a word and `q' to\nkill this buffer\n\n")
+
+ (if (string= word "") (insert "Empty word!\n")
+
+ ;; Insert the response of the 'dict' command
+
+ (condition-case nil
+ (save-excursion
+ (call-process "dict" nil (current-buffer) nil word))
+
+ (error (insert "Can not find the unix `dict' command, is it installed ?\n\n")))
+
+ ;; Remove the spurious whitespaces, underline the "From ..."
+ ;; and highlight the searched word
+
+ (delete-trailing-whitespace)
+
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward "^From.*$" nil t)
+ (add-text-properties (match-beginning 0) (match-end 0) '(face underline)))
+ (goto-char (point-min))
+ (while (re-search-forward word nil t)
+ (add-text-properties (match-beginning 0) (match-end 0) '(face bold))))
+ )
+
+ (setq buffer-read-only t)
+ (set-buffer-modified-p nil)
+ )
+
+ )))
--- /dev/null
+;; -*-Emacs-Lisp-*-
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; This program is free software; you can redistribute it and/or ;;
+;; modify it under the terms of the GNU General Public License as ;;
+;; published by the Free Software Foundation; either version 3, or (at ;;
+;; your option) any later version. ;;
+;; ;;
+;; This program is distributed in the hope that it will be useful, but ;;
+;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;
+;; General Public License for more details. ;;
+;; ;;
+;; You should have received a copy of the GNU General Public License ;;
+;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;
+;; ;;
+;; Written by and Copyright (C) Francois Fleuret ;;
+;; Contact <francois@fleuret.org> for comments & bug reports ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Is it me, or the slave mode of mplayer is ugly to parse ? Did I
+;; miss something ?
+
+(defcustom media/mplayer/args nil
+ "List of arguments for mplayer."
+ :type 'list
+ :group 'media)
+
+(defcustom media/mplayer/timing-request-period 0.25
+ "Period for the timing requests in second(s). Larger values
+load Emacs less. Nil means no timing."
+ :type 'float
+ :group 'media)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; It is impossible to tell mplayer to send information every time dt
+;; or so, hence this mess with a timer to avoid overloading emacs with
+;; the processing of the information
+
+(defvar media/mplayer/timer nil
+ "A timer to request the timing position.")
+
+(defun media/mplayer/timing-request ()
+ (if media/mplayer/process
+ (unless media/mplayer/paused
+ (media/mplayer/write "get_time_pos\n")
+ )
+ (media/mplayer/stop-timing-requests)
+ ))
+
+(defun media/mplayer/start-timing-requests ()
+ (when media/mplayer/timing-request-period
+ (media/mplayer/stop-timing-requests)
+ (setq media/mplayer/timer
+ (run-at-time nil
+ media/mplayer/timing-request-period
+ 'media/mplayer/timing-request))
+ )
+ )
+
+(defun media/mplayer/stop-timing-requests ()
+ (when media/mplayer/timer
+ (cancel-timer media/mplayer/timer)
+ (setq media/mplayer/timer nil)
+ ))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun media/mplayer/filter-subfunctions (cmd param)
+ ;; (unless (string= cmd "A:")
+ ;; (message "cmd=%s param=%s" cmd param)
+ ;; )
+ (eval
+ (cdr
+ (assoc cmd
+
+ '(
+
+ ;; ----------------------------------------
+
+ ("ANS_LENGTH" .
+
+ (setq media/song-duration
+ (string-to-number (substring param 1))))
+
+ ;; ----------------------------------------
+
+ ("ANS_TIME_POSITION" .
+
+ (progn
+ (setq media/song-current-time
+ (string-to-number (substring param 1)))
+
+ (when (and media/duration-to-history
+ (< media/mplayer/cumulated-duration media/duration-to-history))
+
+ (when media/mplayer/last-current-time
+ (setq media/mplayer/cumulated-duration
+ (+ media/mplayer/cumulated-duration
+ (- media/song-current-time media/mplayer/last-current-time))))
+
+ (when (>= media/mplayer/cumulated-duration media/duration-to-history)
+ (media/put-in-history)
+ )
+
+ (setq media/mplayer/last-current-time media/song-current-time)
+ )
+
+
+ )
+ )
+
+ ;; ----------------------------------------
+
+ ("AUDIO:" .
+
+ (progn
+ ;; param = "44100 Hz, 2 ch, s16le, 128.0 kbit/9.07% (ratio: 16000->176400)"
+ (when (string-match "^\\([0-9]+\\) Hz, \\([0-9]+\\) ch.* \\([0-9.]+\\) kbit"
+ param)
+ (setq media/current-information
+ (list media/mplayer/url
+ (string-to-number (match-string 1 param))
+ (string-to-number (match-string 2 param))
+ (string-to-number (match-string 3 param))))
+ )
+ (run-hooks 'media/play-hook)
+ ))
+
+ ;; ----------------------------------------
+
+ ("Starting" .
+ (media/mplayer/write "get_time_length\n"))
+
+ ;; ----------------------------------------
+
+ ("Cache fill:" .
+
+ (when (string-match "(\\([0-9]+\\) bytes" param)
+ (message "Caching stream (%dkb)"
+ (/ (string-to-number (match-string 1 param)) 1024))))
+
+ ;; ----------------------------------------
+
+ ("Exiting..." .
+
+ (progn
+ (setq media/mplayer/exit-type
+ (cdr (assoc param '(("(End of file)" . file-finished)
+ ("(Quit)" . quit))))
+ media/current-information nil
+ media/song-duration nil
+ media/song-current-time nil)
+
+ (when media/mplayer/process (kill-process media/mplayer/process))
+
+ (force-mode-line-update)))
+
+ ;; ----------------------------------------
+
+ )
+ ))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun media/mplayer/filter (process str)
+ (setq media/mplayer/buffer (concat media/mplayer/buffer str))
+ (let ((start 0))
+ (while (and (< start (length media/mplayer/buffer))
+ (string-match "\\(.*\\)[\n\r]+" media/mplayer/buffer start))
+ (setq start (1+ (match-end 1)))
+ (let ((line (match-string 1 media/mplayer/buffer)))
+ (when (string-match "^\\(AUDIO:\\|Exiting...\\|Starting\\|ANS_LENGTH\\|ANS_TIME_POSITION\\|Cache fill:\\) *\\(.*\\)$" line)
+ (media/mplayer/filter-subfunctions (match-string 1 line) (match-string 2 line)))))
+ (setq media/mplayer/buffer (substring media/mplayer/buffer start)))
+ )
+
+(defun media/mplayer/sentinel (process str) ()
+ ;; (message "Media process got \"%s\"" (replace-regexp-in-string "\n" "" str))
+ (unless (eq (process-status media/mplayer/process) 'run)
+ (setq media/current-information nil
+ media/mplayer/process nil
+ media/song-current-time nil
+ media/song-duration nil)
+
+ (media/mplayer/stop-timing-requests)
+
+ (if (eq media/mplayer/exit-type 'file-finished)
+ (run-hooks 'media/finished-hook)
+ (run-hooks 'media/error-hook))
+
+ (force-mode-line-update))
+ )
+
+(defun media/mplayer/write (&rest l)
+ ;; (message "****** WROTE \"%s\"" (replace-regexp-in-string "\n" "[RETURN]" (apply 'format l)))
+ (if media/mplayer/process (process-send-string media/mplayer/process (apply 'format l))
+ (error "No mplayer process"))
+ )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Player control abstract layer ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun media/api/init () "Called once when the media application starts"
+ (setq media/player-id "MPlayer"
+ media/mplayer/url nil
+ media/mplayer/buffer "" ;; Used as read buffer
+ media/mplayer/process nil
+ media/mplayer/exit-type nil
+ media/mplayer/paused nil
+ media/song-duration nil
+ media/song-current-time nil
+ media/mplayer/cumulated-duration 0
+ media/mplayer/last-current-time nil
+ ))
+
+(defun media/api/cleanup () "Called when killing the application's buffer"
+ (when media/mplayer/process
+ (delete-process media/mplayer/process)
+ (media/mplayer/stop-timing-requests)
+ (setq media/mplayer/process nil)))
+
+(defun media/api/play (url) (interactive)
+ (setq media/mplayer/url url)
+
+ (when media/mplayer/process (kill-process media/mplayer/process))
+
+ ;; (if media/mplayer/process
+ ;; (media/mplayer/write (concat "loadfile "
+ ;; (replace-regexp-in-string "^file://" "" media/mplayer/url)
+ ;; "\n"))
+
+ (setq media/mplayer/process
+ (apply
+ 'start-process
+ (append
+ '("mplayer" nil "mplayer" "-slave" "-quiet")
+ media/mplayer/args
+ (if (string-match "\\(asx\\|m3u\\|pls\\|ram\\)$" media/mplayer/url)
+ (list "-playlist"))
+ (list (replace-regexp-in-string "^file://" "" media/mplayer/url))))
+ media/mplayer/exit-type 'unknown
+ media/mplayer/paused nil
+ media/song-duration nil
+ media/song-current-time nil
+ media/mplayer/cumulated-duration 0
+ media/mplayer/last-current-time nil
+ )
+
+ (set-process-filter media/mplayer/process 'media/mplayer/filter)
+ (set-process-sentinel media/mplayer/process 'media/mplayer/sentinel)
+ (process-kill-without-query media/mplayer/process)
+ (media/mplayer/start-timing-requests)
+ (media/mplayer/write "get_time_pos\n")
+
+ )
+
+(defun media/api/stop () (interactive)
+ (media/mplayer/write "quit\n")
+ )
+
+(defun media/api/pause () (interactive)
+ (media/mplayer/write "pause\n")
+ (setq media/mplayer/paused (not media/mplayer/paused))
+ )
+
+(defun media/api/set-volume (mode value) (interactive)
+ (if (eq mode 'absolute)
+ (media/mplayer/write "volume %s 1\n" value)
+ (if (>= value 0)
+ (media/mplayer/write "volume +%s\n" value)
+ (media/mplayer/write "volume %s\n" value))))
+
+(defun media/api/jump-at-percent (percent) (interactive)
+ (setq media/song-current-time nil)
+ (when (< media/mplayer/cumulated-duration media/duration-to-history)
+ (setq media/mplayer/cumulated-duration 0
+ media/mplayer/last-current-time nil))
+ (media/mplayer/write "seek %s 1\n" percent)
+ (media/mplayer/write "get_time_pos\n")
+ )
+
+(defun media/api/jump-at-time (mode time) (interactive)
+ (setq media/song-current-time nil)
+ (when (< media/mplayer/cumulated-duration media/duration-to-history)
+ (setq media/mplayer/cumulated-duration 0
+ media/mplayer/last-current-time nil))
+ (if (eq mode 'absolute)
+ (media/mplayer/write "seek %s 2\n" time)
+ (media/mplayer/write "seek %s 0\n" time))
+ (media/mplayer/write "get_time_pos\n")
+ )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
--- /dev/null
+;; -*-Emacs-Lisp-*-
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; This program is free software; you can redistribute it and/or ;;
+;; modify it under the terms of the GNU General Public License as ;;
+;; published by the Free Software Foundation; either version 3, or (at ;;
+;; your option) any later version. ;;
+;; ;;
+;; This program is distributed in the hope that it will be useful, but ;;
+;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;
+;; General Public License for more details. ;;
+;; ;;
+;; You should have received a copy of the GNU General Public License ;;
+;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;
+;; ;;
+;; Written by and Copyright (C) Francois Fleuret ;;
+;; Contact <francois@fleuret.org> for comments & bug reports ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; A simple front-end major mode for command line media players (only
+;; mplayer for now, feel free to write the code for others)
+;;
+;; The strict minimum is to set in your ~/.emacs the variable
+;; media/url-list to the list of directories where to pick the tunes
+;; and the URLs of streams. For the latter you can also specify a name
+;; that will appear in the interface instead of the URL itself.
+;;
+;; I have in my ~/.emacs
+;;
+;; (when (load "media" nil t)
+;;
+;; (setq media/expert t
+;; media/add-current-song-to-interrupted-when-killing t
+;; media/duration-to-history 30
+;; media/history-size 1000
+;; media/playlist-file "~/private/media-playlists"
+;; media/mplayer/args '("-framedrop" "-zoom" "-subfont-osd-scale" "3" "-osdlevel" "3")
+;; media/mplayer/timing-request-period 1.0
+;; media/url-list '("~/mp3"
+;; ("http://www.technomusic.com/live/hi/pls" . "Technomusic.com")
+;; ("http://www.fullhouseradio.com/listen.pls" . "Full House Radio")
+;; ("mms://live.france24.com/france24_fr.wsx" . "France 24")
+;; ))
+;;
+;; (define-key global-map [(meta \\)] 'media)
+;; )
+;;
+;; If you put media.el and media-mplayer.el in an exotic directory,
+;; you have to tell emacs to look for them there by adding something
+;; like (add-to-list 'load-path "~/exotic/") before the (load "media")
+;; command.
+
+(defgroup media ()
+ "Major mode to control media players"
+ :version "1.2.1")
+
+(defcustom media/player-api "media-mplayer"
+ "The file to load for the abstract layer with the media player."
+ :type 'string
+ :group 'media)
+
+(defcustom media/url-list '()
+ "List of directories to be imported and urls. Each element can be
+either a string containing a directory or an url, or a cons cell the
+first element of which is a string containing a url and the second a
+title to display in the list (convenient for internet radios)."
+ :type 'list
+ :group 'media)
+
+(defcustom media/playlist-file "~/.media-playlists"
+ "Where to save the playlists."
+ :type 'string
+ :group 'media)
+
+(defcustom media/duration-to-history 5
+ "Duration in seconds after which the song should be put in the history."
+ :type 'integer
+ :group 'media)
+
+(defcustom media/playlist-at-top nil
+ "Should the playlists be created at the top of the media buffer ?"
+ :type 'bool
+ :group 'media)
+
+(defcustom media/add-current-song-to-interrupted-when-killing nil
+ "Should we save the current song with time in the Interrupted playlist ?"
+ :type 'bool
+ :group 'media)
+
+(defcustom media/do-not-remove-nonexisting-entries nil
+ "Should we remove the entries corresponding to a non-existing file when saving the playlists ?"
+ :type 'bool
+ :group 'media)
+
+(defcustom media/history-size 0
+ "How many songs to keep in the history list."
+ :type 'integer
+ :group 'media)
+
+(defcustom media/continue-mode nil
+ "Should the player start the next song in the buffer when the current terminates ?"
+ :type 'boolean
+ :group 'media)
+
+(defcustom media/expert nil
+ "Should the keymap help be shown ?"
+ :type 'boolean
+ :group 'media)
+
+(defvar media/current-information nil
+ "Contains the name of the current file playing, the frequency in Hz
+and the bitrate. Should be nil if no information is available.")
+
+(defvar media/buffer nil
+ "The main buffer for the media player mode.")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Hooks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defcustom media/finished-hook '(media/song-terminates)
+ "Hook called when the current playing song/movie terminates."
+ :type 'hook
+ :group 'media)
+
+(defcustom media/starting-hook nil
+ "Hook called after the media buffer has been set up."
+ :type 'hook
+ :group 'media)
+
+(defcustom media/before-play-hook nil
+ "Hook called before starting the player on a new song."
+ :type 'hook
+ :group 'media)
+
+(defcustom media/play-hook '(media/show-current-information)
+ "Hook called when a song starts to play."
+ :type 'hook
+ :group 'media)
+
+(defcustom media/error-hook '(media/player-error)
+ "Hook called when a player error occurs."
+ :type 'hook
+ :group 'media)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Faces ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defface media/playlist-face
+ '((((background dark)) (:foreground "blue" :bold t))
+ (((background light)) (:foreground "blue" :bold t)))
+ "Face for playlist names."
+ :group 'media)
+
+(defface media/directory-face
+ '((((background dark)) (:foreground "green" :bold t))
+ (((background light)) (:foreground "forest green" :bold t)))
+ "Face for directories."
+ :group 'media)
+
+(defface media/timestamp-face
+ '((((background dark)) (:foreground "turquoise"))
+ (((background light)) (:foreground "blue")))
+ "Face for the stored timestamps."
+ :group 'media)
+
+(defface media/nonexisting-face
+ '((((background dark)) (:foreground "red"))
+ (((background light)) (:foreground "red3")))
+ "Face for non-existing files."
+ :group 'media)
+
+(defface media/stream-face
+ '((((background dark)) (:foreground "green"))
+ (((background light)) (:foreground "green3")))
+ "Face for non-files urls."
+ :group 'media)
+
+(defface media/current-tune-face
+ '((((background dark)) (:foreground "gray80" :background "black"))
+ (((background light)) (:foreground "black" :background "yellow")))
+ "Highlight of the currently playing tune."
+ :group 'media)
+
+(defface media/instant-highlight-face
+ '((((background dark)) (:foreground "black" :background "lawn green"))
+ (((background light)) (:foreground "black" :background "lawn green")))
+ "Brief highlight when adding a tune to the \"Queue\" list."
+ :group 'media)
+
+(defface media/mode-string-face
+ '((t (:foreground "darkblue" :bold t)))
+ "The face to display the media info in the modeline."
+ :group 'media)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Various initializations
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(setq media/current-overlay nil
+ media/instant-highlight-overlay nil
+ media/instant-highlight-timer nil
+ media/active-playlist nil)
+
+(defun media/goto-top ()
+ (goto-char (text-property-any (point-min) (point-max) 'prologue nil)))
+
+(defun media/goto-next-playlist-or-dir () (interactive)
+ (goto-char (min (next-single-char-property-change (point) 'playlist)
+ (next-single-char-property-change (point) 'dir)))
+ (unless (< (point) (point-max)) (goto-char (point-min)))
+ (unless (or (get-text-property (point) 'playlist)
+ (get-text-property (point) 'dir))
+ (goto-char (min (next-single-char-property-change (point) 'playlist)
+ (next-single-char-property-change (point) 'dir))))
+ )
+
+(defun media/goto-previous-playlist-or-dir () (interactive)
+ (goto-char (max (previous-single-char-property-change (point) 'playlist)
+ (previous-single-char-property-change (point) 'dir)))
+ (unless (> (point) (point-min)) (goto-char (point-max)))
+ (unless (or (get-text-property (point) 'playlist)
+ (get-text-property (point) 'dir))
+ (goto-char (max (previous-single-char-property-change (point) 'playlist)
+ (previous-single-char-property-change (point) 'dir))))
+ )
+
+(defun media/remove-instant-highlight ()
+ (move-overlay media/instant-highlight-overlay 0 0)
+ (setq media/instant-highlight-timer nil)
+ )
+
+(defun media/instant-highlight (start end)
+ (move-overlay media/instant-highlight-overlay start end)
+ (when media/instant-highlight-timer
+ (cancel-timer media/instant-highlight-timer))
+ (setq media/instant-highlight-timer
+ (run-at-time 0.25 nil 'media/remove-instant-highlight)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Finding and playing URLs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun media/format-url (url)
+ (if (string-match "^file:.*/\\([^/]+\\)$" url)
+ (match-string 1 url)
+ url)
+ )
+
+(defun media/play-position (position) (interactive)
+ (let ((url (get-text-property position 'url))
+ (time (get-text-property position 'time)))
+ (if (not url) (media/remove-highlight)
+ (run-hook-with-args 'media/before-play-hook url)
+ (media/api/play url)
+ ;; We keep the information of the url and the title
+ (setq media/played-information (cons url (get-text-property position 'title)))
+ (media/move-highlight position)
+ (when time (media/api/jump-at-time 'absolute time))
+ )))
+
+(defun media/play-or-active-at-point () (interactive)
+ (if (get-text-property (point) 'url)
+ (media/play-position (point))
+ (let ((playlist (get-text-property (point) 'playlist)))
+ (when playlist
+ (setq media/active-playlist playlist)
+ (message "Active playlist is %s" media/active-playlist)))))
+
+(defun media/goto-next () (interactive)
+ (let ((p (next-single-char-property-change (point) 'url)))
+ (while (and (< p (point-max)) (not (get-text-property p 'url)))
+ (setq p (next-single-char-property-change p 'url)))
+ (when (get-text-property p 'url)
+ (goto-char p))))
+
+(defun media/play-next (&optional dont-move) (interactive)
+ (let ((p (next-single-char-property-change (overlay-start media/current-overlay) 'url)))
+ (while (and (< p (point-max)) (not (get-text-property p 'url)))
+ (setq p (next-single-char-property-change p 'url)))
+ (if (not (get-text-property p 'url))
+ (media/remove-highlight)
+ (media/play-position p)
+ (unless (or ;;(pos-visible-in-window-p p)
+ dont-move)
+ (goto-char p)))))
+
+(defun media/play-prev () (interactive)
+ (let ((p (previous-single-char-property-change (overlay-start media/current-overlay) 'url)))
+ (while (and (> p (point-min)) (not (get-text-property p 'url)))
+ (setq p (previous-single-char-property-change p 'url)))
+ (when (get-text-property p 'url)
+ (media/play-position p))
+ ;; (unless (pos-visible-in-window-p p)
+ (goto-char p)
+ ;; )
+ ))
+
+(defun media/move-highlight (position)
+ (move-overlay media/current-overlay
+ (previous-property-change (1+ position))
+ ;; (next-property-change position)
+ ;; (previous-single-char-property-change (1+ position) 'url)
+ (next-single-char-property-change position 'url)
+ ))
+
+(defun media/remove-highlight ()
+ (move-overlay media/current-overlay 0 0))
+
+(defun media/goto-current () (interactive)
+ (goto-char (overlay-start media/current-overlay)))
+
+(defun media/jump-at-percent (&optional perc)
+ "Goes to a certain % of the song"
+ (interactive "P")
+ (media/api/jump-at-percent
+ (max 0
+ (min 100
+ (or perc
+ (string-to-number (read-from-minibuffer "Percentage: ")))))))
+
+(defun media/refresh-list (&optional dir) (interactive)
+ (when media/buffer
+ (let* ((current (overlay-end media/current-overlay))
+ (url (get-text-property current 'url))
+ ;; (playlist (get-text-property current 'playlist))
+ (w (get-buffer-window media/buffer)))
+
+ (if (not w) (media/full-refresh)
+ (let ((p (point))
+ (s (window-start w)))
+ (media/full-refresh)
+ (goto-char p)
+ (set-window-start w s)))
+
+ ))
+
+ ;; TODO: Move the overlay where they were before refresh
+
+ (message "Refreshed!"))
+
+;; TODO: Refresh only the directories which have to be
+
+(defun media/rename-point () (interactive)
+ (let ((url (get-text-property (point) 'url)))
+ (when (and url (string-match "^file:/*\\(/.+\\)$" url))
+ (let* ((original (match-string-no-properties 1 url))
+ (new (read-from-minibuffer "New name: " original)))
+ (if (string= original new)
+ (message "Cancel")
+ (message "Renaming %s to %s" original new)
+ (rename-file original new)
+ (media/refresh-list (file-name-directory original))
+ (unless (string= (file-name-directory original) (file-name-directory new))
+ (media/refresh-list (file-name-directory new)))
+ )))))
+
+(defun media/move-point-to-tmp () (interactive)
+ (let ((url (get-text-property (point) 'url)))
+ (unless (and url (string-match "^file:/*\\(/.+\\)$" url))
+ (error "No file here"))
+ (let* ((original (match-string-no-properties 1 url))
+ (new (replace-regexp-in-string "^.*/" "/tmp/" original)))
+ (if (string= original new)
+ (message "Cancel")
+ (message "Renaming %s into %s" original new)
+ (rename-file original new)
+ (media/refresh-list (file-name-directory original))
+ ))))
+
+(setq media/id3-genre-table
+ [ "Blues" "Classic Rock" "Country" "Dance" "Disco" "Funk"
+ "Grunge" "Hip-Hop" "Jazz" "Metal" "New Age" "Oldies"
+ "Other" "Pop" "R&B" "Rap" "Reggae" "Rock"
+ "Techno" "Industrial" "Alternative" "Ska" "Death Metal" "Pranks"
+ "Soundtrack" "Euro-Techno" "Ambient" "Trip-Hop" "Vocal" "Jazz+Funk"
+ "Fusion" "Trance" "Classical" "Instrumental" "Acid" "House"
+ "Game" "Sound Clip" "Gospel" "Noise" "Alternative Rock" "Bass"
+ "Soul" "Punk" "Space" "Meditative" "Instrumental Pop"
+ "Instrumental Rock" "Ethnic" "Gothic" "Darkwave" "Techno-Industrial"
+ "Electronic" "Pop-Folk" "Eurodance" "Dream" "Southern Rock" "Comedy"
+ "Cult" "Gangsta" "Top 40" "Christian Rap" "Pop/Funk" "Jungle"
+ "Native US" "Cabaret" "New Wave" "Psychadelic" "Rave" "Showtunes"
+ "Trailer" "Lo-Fi" "Tribal" "Acid Punk" "Acid Jazz" "Polka" "Retro"
+ "Musical" "Rock & Roll" "Hard Rock" "Folk" "Folk-Rock" "National Folk"
+ "Swing" "Fast Fusion" "Bebob" "Latin" "Revival" "Celtic" "Bluegrass"
+ "Gothic Rock" "Progressive Rock" "Psychedelic Rock" "Symphonic Rock"
+ "Slow Rock" "Big Band" "Chorus" "Easy Listening" "Acoustic" "Humour"
+ "Speech" "Chanson" "Opera" "Chamber Music" "Sonata" "Symphony"
+ "Booty Bass" "Primus" "Porn Groove" "Satire" "Slow Jam" "Club" "Tango"
+ "Samba" "Folklore" "Ballad" "Power Ballad" "Rythmic Soul" "Freestyle"
+ "Duet" "Punk Rock" "Drum Solo" "Acapella" "Euro-House" "Dance Hall"
+ "Goa" "Drum & Bass" "Club-House" "Hardcore" "Terror" "Indie" "BritPop"
+ "Negerpunk" "Polsk Punk" "Beat" "Christian Gangsta Rap" "Heavy Metal"
+ "Black Metal" "Crossover" "Contemporary Christian" "Christian Rock"
+ "Merengue" "Salsa" "Trash Metal" ])
+
+(defun media/get-file-id3-tags (file)
+ "Returns the id3 tags in a list (SONG ARTIST ALBUM YEAR NOTE GENRE),
+returns nil if no id3 tags could be found."
+ (let ((size (elt (file-attributes file) 7)))
+ (unless (integerp size) (error "Can not read the file ID3 information (file probably too big)"))
+ (with-temp-buffer
+ (when (and (> size 128)
+ (insert-file-contents-literally file nil (- size 128) size t)
+ (string= (buffer-substring 1 4) "TAG"))
+ ;; Here we have the 128 last bytes of the file in a temporary
+ ;; buffer, and the three first characters are "TAG"
+ (append
+ ;; We get the 5 first id3s
+ (mapcar (lambda (pos)
+ (replace-regexp-in-string
+ "[\0 ]*$" ""
+ (buffer-substring (car pos) (cdr pos))))
+ '((4 . 34) (34 . 64) (64 . 94) (94 . 98) (98 . 127)))
+ ;; And we decode the last one with the genre table
+ (list
+ (condition-case nil
+ (elt media/id3-genre-table (string-to-char
+ (buffer-substring 128 129)))
+ (error "<Error>"))))))))
+
+(defun media/show-id3-at-point ()
+ (interactive)
+ (let ((url (get-text-property (point) 'url)))
+ (when url
+ (if (not (string-match "^file:/*\\(/.+\\)$" url))
+ (message "This is not a file!")
+ (let* ((filename (match-string-no-properties 1 url)))
+ (if (file-exists-p filename)
+ (let ((id3tags (media/get-file-id3-tags filename)))
+ (if id3tags
+ (message
+ "%s Song [%s] Artist [%s] Album [%s] Year [%s] Note [%s] Genre [%s]"
+ filename
+ (elt id3tags 0)
+ (elt id3tags 1)
+ (elt id3tags 2)
+ (elt id3tags 3)
+ (elt id3tags 4)
+ (elt id3tags 5))
+ (message "%s (no id3 tags) " filename)))
+ (message "No such file (%s)!" filename)))))))
+
+(defun media/rename-point-according-to-id3 ()
+ "Renames the file located at point, according to the ID3 tags"
+ (interactive)
+ (let ((url (get-text-property (point) 'url)))
+ (when (and url (string-match "^file:/*\\(/.+\\)$" url))
+ (if (file-exists-p (match-string-no-properties 1 url))
+ (let* ((filename (match-string-no-properties 1 url))
+ (id3tags (media/get-file-id3-tags filename)))
+ (if id3tags
+ (let* ((original (match-string-no-properties 1 url))
+ (new (read-from-minibuffer "New name: "
+ (replace-regexp-in-string
+ " " "_"
+ (concat (replace-regexp-in-string
+ "[^/]+$" "" (match-string-no-properties 1 url))
+ (elt id3tags 1)
+ "_-_"
+ (elt id3tags 0)
+ ".mp3")))))
+ (if (string= original new)
+ (message "Cancel")
+ (message "Renaming %s into %s" original new)
+ (rename-file original new)
+ (media/refresh-list)
+ ))
+ (message "%s (no id3 tags) " filename)))
+ (message "No such file!")))))
+
+;; TODO: Finish
+
+(defun media/edit-id3-at-point ()
+ "Open a new buffer with the ID3 fields of the file on line editable."
+ (interactive)
+ (let ((url (get-text-property (point) 'url)))
+ (when (and url (string-match "^file:/*\\(/.+\\)$" url))
+ (if (file-exists-p (match-string-no-properties 1 url))
+ (let* ((filename (match-string-no-properties 1 url))
+ (id3tags (or (media/get-file-id3-tags filename) '("-" "-" "-" "-" "-" "-"))))
+ (let ((map (make-sparse-keymap)))
+
+ (switch-to-buffer (get-buffer-create (generate-new-buffer-name "*media ID3 editor*")))
+
+ (text-mode)
+ (auto-fill-mode)
+
+ (mapc (lambda (s)
+ (insert (if (numberp s) (elt id3tags s)
+ (propertize s 'read-only t 'rear-nonsticky '(read-only)))))
+
+ '("SONG: " 0 "\n"
+ "ARTIST: " 1 "\n"
+ "ALBUM: " 2 "\n"
+ "YEAR: " 3 "\n"
+ "NOTE: " 4 "\n"
+ "GENRE: " 5 "\n"))
+
+ (goto-char (point-min))
+ (re-search-forward "SONG: ")
+
+ (define-key map (kbd "TAB")
+ (lambda () (interactive)
+ (unless (re-search-forward ": +" nil t)
+ (goto-char (point-min))
+ (re-search-forward ": +" nil t))))
+
+ (define-key map [(control c) (control c)]
+ (lambda () (interactive)
+ (kill-this-buffer)
+ )
+ )
+
+ (define-key map [(control c) (control q)]
+ (lambda () (interactive)
+ (kill-this-buffer)
+ (message "Cancel")
+ ))
+
+ (use-local-map map)
+ (message "C-c C-c to save the information, C-c C-q to cancel")
+ )
+ )
+ )
+ )
+ )
+ )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Adding objects in the buffer ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun media/separator ()
+ (unless (and (eq (char-before) ?\n) (eq (char-before (1- (point))) ?\n))
+ (insert "\n")))
+
+(defun media/insert-url (url depth &optional info)
+ (insert
+ (if (listp url)
+ (propertize (concat " "
+ (make-string (* 2 depth) ?\ )
+ info
+ " "
+ (media/format-url (cdr url)) "\n")
+ 'url (car url)
+ 'title (cdr url))
+
+ (propertize (concat " "
+ (make-string (* 2 depth) ?\ )
+ info
+ " "
+ (media/format-url url) "\n")
+ 'url url
+ 'title nil))
+ ))
+
+(defun media/string-from-size (size)
+ (if (< size 1024) (format "%5db" size)
+ (if (< size 1048576) (format "%5dk" (ash size -10))
+ (format "%5.01fM" (/ size 1048576.0))
+ )))
+
+(defun media/insert-file (filename depth)
+ (media/insert-url (concat "file://" (file-truename filename))
+ depth
+ (concat (media/string-from-size (nth 7 (file-attributes filename))) " --")
+ ))
+
+(defun media/insert-dir (filename depth)
+ (media/separator)
+
+ (insert (propertize (concat " "
+ (make-string (* 2 depth) ?\ )
+ filename
+ "\n") 'face 'media/directory-face 'dir filename))
+
+ (media/separator)
+
+ (let ((dircontent (directory-files-and-attributes filename)))
+
+ (mapc (lambda (file)
+ (unless (string-match "^\\." (car file))
+ (let ((url (concat filename "/" (car file))))
+ (when (file-regular-p url)
+ (media/insert-file url depth)))))
+ dircontent)
+
+ (media/separator)
+
+ (mapc (lambda (file)
+ (unless (string-match "^\\." (car file))
+ (let ((url (concat filename "/" (car file))))
+ (when (file-directory-p url)
+ (media/insert-dir url (1+ depth))))))
+ dircontent)
+ )
+ )
+
+(defun media/import (list)
+
+ (message "Importing the list of URLs")
+
+ (media/separator)
+
+ (mapc (lambda (c)
+ (let* ((url (or (and (consp c) (car c)) c))
+ (title (or (and (consp c) (cdr c)) url)))
+ (if (string-match "^\\(http\\|mms\\)://" url)
+ (media/insert-url (cons url title) 0)
+ (if (file-regular-p url) (media/insert-file url 0)
+ (if (file-directory-p url) (media/insert-dir url 0)
+ (error "Unknown type `%s'" url))))))
+ list))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Saving and loading the buffer ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun media/save-playlists () (interactive)
+
+ (let ((list '()))
+
+ (with-current-buffer media/buffer
+ (let ((pos (point-min))
+ (end (point-max)))
+
+ (while (< (setq pos
+ (next-single-char-property-change pos 'url)
+ ;; (min (next-single-char-property-change pos 'url)
+ ;; (next-single-char-property-change pos 'time))
+ ) end)
+
+ (let ((url (get-text-property pos 'url))
+ (title (get-text-property pos 'title))
+ (time (get-text-property pos 'time))
+ (playlist (get-text-property pos 'playlist)))
+
+ ;; (message "url=%s title=%s time=%s playlist=%s"
+ ;; (prin1-to-string url)
+ ;; (prin1-to-string title)
+ ;; (prin1-to-string time)
+ ;; (prin1-to-string playlist))
+
+ (when (and playlist url)
+ (unless (assoc playlist list) (push (list playlist) list))
+ (push (cons url (cons title time)) (cdr (assoc playlist list)))
+ )))))
+
+ (save-excursion
+ (set-buffer (find-file-noselect media/playlist-file))
+ (erase-buffer)
+ (mapc (lambda (x)
+ (insert "PLAYLIST:" (car x) "\n")
+ (mapc (lambda (y)
+ (when (or media/do-not-remove-nonexisting-entries
+ (not (string-match "^file:" (car y)))
+ (file-exists-p (replace-regexp-in-string "^file://" "" (car y))))
+ (when (car (cdr y)) (insert "TITLE:" (car (cdr y)) "\n"))
+ (when (cdr (cdr y)) (insert "TIME:" (number-to-string (cdr (cdr y))) "\n"))
+ (insert "URL:" (car y) "\n")))
+ (reverse (cdr x)))
+ )
+ (reverse list))
+ (set-buffer-file-coding-system 'utf-8)
+ (save-buffer)
+ (kill-this-buffer)
+ ))
+
+ (set-buffer-modified-p nil))
+
+(defun media/load-playlists () (interactive)
+ (if (file-exists-p media/playlist-file)
+ (with-temp-buffer
+ (insert-file media/playlist-file)
+ ;; (insert-file-contents-literally media/playlist-file)
+ (goto-char (point-min))
+ (let ((playlist nil)
+ (title nil)
+ (time nil))
+ (while (re-search-forward "^\\([A-Z]*\\):\\(.*\\)$" nil t)
+ (eval (cdr (assoc (match-string-no-properties 1)
+ '(("PLAYLIST" . (setq playlist (match-string-no-properties 2)))
+ ("TITLE" . (setq title (match-string-no-properties 2)))
+ ("TIME" . (setq time (string-to-number (match-string-no-properties 2))))
+ ("URL" . (save-excursion
+ (media/add-song-to-playlist
+ playlist (match-string-no-properties 2) title time)
+ (setq title nil
+ time nil)))))))
+ )))))
+
+(defun media/select-active-playlist ()
+ (interactive)
+ (with-current-buffer media/buffer
+ (let ((playlists nil)
+ (pos (point-min))
+ (end (point-max)))
+
+ ;; Build the list of existing playlists
+ (while (< (setq pos (next-single-char-property-change pos 'playlist)) end)
+ (add-to-list 'playlists (list (get-text-property pos 'playlist))))
+
+ (setq media/active-playlist
+ (completing-read "Select playlist: " playlists))
+
+ (message "Using `%s' as active playlist" media/active-playlist)))
+ )
+
+(defun media/create-playlist (name)
+ (interactive "MPlaylist to create: ")
+ (when (media/playlist-position name) (error "Playlist already existing"))
+ (save-excursion
+ (if media/playlist-at-top (media/goto-top)
+ (goto-char (point-max)))
+ (media/separator)
+ (insert (propertize (concat " " name "\n") 'playlist name 'face 'media/playlist-face)
+ (propertize "\n" 'playlist name)
+ )
+ (setq media/active-playlist name)
+ (message "Playlist `%s' created" name)))
+
+(defun media/playlist-position (name)
+ "Returns the position where the given playlist starts."
+ (let ((pos (point-min)))
+ (while (and (setq pos (next-single-char-property-change pos 'playlist))
+ (not (string= name (get-text-property pos 'playlist)))
+ (< pos (point-max))))
+ (and (< pos (point-max)) pos)))
+
+;; (defun media/playlist-position (name)
+;; (text-property-any (point-min) (point-max) 'playlist name))
+
+;; (defun media/url-position (url &optional playlist)
+;; (let ((pos (point-min)))
+;; (while (and (setq pos (next-single-char-property-change pos 'playlist))
+;; (not (string= name (get-text-property pos 'playlist)))
+;; (< pos (point-max))))
+;; (and (< pos (point-max)) pos)))
+
+(defun media/playlist-content (playlist)
+ (let ((pos (point-min))
+ (urls ()))
+ (while (and (setq pos (next-single-char-property-change pos 'url))
+ (string= playlist (get-text-property pos 'playlist))
+ (< pos (point-max)))
+ (setq urls (cons (cons pos (get-text-property pos 'url)) urls)))
+ (nreverse urls)))
+
+(defun media/put-in-history ()
+ (set-buffer media/buffer)
+ (when (> media/history-size 0)
+ (let* ((urls (media/playlist-content "History"))
+ (l (length urls))
+ (current-url (car media/current-information))
+ ;; For the title, if the URL we are actually playing is the
+ ;; one we intended to play, we use the accompagnying title
+ (current-title
+ (if (string= (car media/played-information) current-url)
+ (cdr media/played-information))))
+
+ (media/add-song-to-playlist "History" current-url current-title)
+
+ (when (> (1+ l) media/history-size)
+ (delete-region (car (car urls))
+ (car (nth (- l media/history-size) urls)))))))
+
+(defun media/add-song-at-point-to-active-playlist () (interactive)
+ (if media/active-playlist
+ (let ((url (get-text-property (point) 'url))
+ (title (get-text-property (point) 'title))
+ (time (get-text-property (point) 'time)))
+ (if (not url) (error "No song at point")
+ (media/add-song-to-playlist media/active-playlist url title time)
+ (message "Added %s to playlist `%s'" (or title url) media/active-playlist)
+ (media/instant-highlight
+ (previous-single-char-property-change (1+ (point)) 'url)
+ (next-single-char-property-change (point) 'url))
+ (media/goto-next)))
+ (error "No current playlist")))
+
+(defun media/add-current-song-to-active-playlist (&optional settime) (interactive "P")
+ (if media/active-playlist
+ (let ((url (get-text-property (overlay-start media/current-overlay) 'url))
+ (title (get-text-property (overlay-start media/current-overlay) 'title)))
+ (if (not url) (error "No current song")
+ (media/add-song-to-playlist media/active-playlist url title (and settime media/song-current-time))
+ (message "Added %s to playlist `%s'" (or title url) media/active-playlist)))
+ (error "No current playlist")))
+
+(defun media/add-song-to-playlist (playlist url &optional title time)
+ (set-buffer media/buffer)
+ (let ((pos (or (media/playlist-position playlist)
+ (progn (media/create-playlist playlist)
+ (media/playlist-position playlist)))))
+ (unless pos (error (format "Weird: There is no playlist \"%s\" but can not create it") playlist))
+ (save-excursion
+ (goto-char (next-single-char-property-change pos 'playlist))
+ (prog1 (point)
+ (insert (propertize (concat
+ " "
+ (or title (media/format-url url))
+ (if time (propertize
+ (concat " ->" (media/duration-to-string time))
+ ;; (concat " [@ " (media/duration-to-string time) "]")
+ 'face 'media/timestamp-face
+ ))
+ "\n"
+ )
+ 'url url
+ 'title title
+ 'time time
+ 'playlist (get-text-property (1- (point)) 'playlist))))
+ )))
+
+(defun media/pause () (interactive)
+ (message "Pause")
+ (media/api/pause))
+
+(defun media/stop () (interactive)
+ (message "Stop")
+ (media/api/stop))
+
+(defun media/queue-song-at-point ()
+ "Switches to the 'continue' mode. If a song is currently playing and
+not in the 'Queue' playlist, adds it. Then, adds the url at point to
+the 'Queue' playlist, and plays it if no song is currently playing."
+ (interactive)
+
+ ;; If a song is playing and not in the the Queue list, put it
+
+ (when (and media/current-information
+ (not (string= (get-text-property (overlay-end media/current-overlay) 'playlist)
+ "Queue")))
+
+ (let* ((url (nth 0 media/current-information))
+ (title (if (string= (car media/played-information) url) (cdr media/played-information)))
+ (pos (media/add-song-to-playlist "Queue" url title)))
+
+ (move-overlay media/current-overlay
+ pos
+ (next-single-char-property-change pos 'url))))
+
+ (let* ((position (point)))
+ (media/instant-highlight
+ (previous-single-char-property-change (1+ position) 'url)
+ (next-single-char-property-change position 'url))
+ )
+
+ (let* ((position (point))
+ (url (get-text-property position 'url))
+ (title (get-text-property position 'title))
+ (time (get-text-property position 'time))
+ (pos (and url (media/add-song-to-playlist "Queue" url title time))))
+
+ (when (and pos (not media/current-information)) (media/play-position pos))
+
+ (next-line 1)
+ (setq media/continue-mode t)
+ (force-mode-line-update)
+ )
+
+ )
+
+(defun media/add-song (url) (interactive))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun media/switch-continue-mode ()
+ "Switches between a mode which automatically chains files and a mode
+which stops when the songs ends."
+ (interactive)
+ (setq media/continue-mode (not media/continue-mode))
+ (force-mode-line-update)
+ (if media/continue-mode (message "Continue mode switched on.")
+ (message "Continue mode switched off."))
+ )
+
+(defun media/player-error ()
+ (message "Player error")
+ (media/remove-highlight))
+
+(defun media/song-terminates ()
+ (with-current-buffer media/buffer
+ (if media/continue-mode (media/play-next t)
+ (media/remove-highlight))))
+
+(defun media/duration-to-string (duration)
+ (let ((sec (mod duration 60))
+ (min (/ duration 60)))
+ (if (zerop duration) "0s"
+ (concat (if (>= min 1) (format "%dm" min))
+ (if (>= sec 1) (format "%ds" sec)))
+ )))
+
+(defun media/mode-string ()
+ (propertize
+ (concat
+ " "
+ media/player-id
+ (if media/continue-mode "*")
+ " "
+
+ (if media/current-information
+ (if media/song-current-time
+ (media/duration-to-string media/song-current-time)
+ "?"
+ ))
+
+ (if (and media/song-duration (> media/song-duration 0))
+ (concat "/"
+ (media/duration-to-string media/song-duration)))
+ )
+
+ 'face 'media/mode-string-face)
+ )
+
+(defun media/show-current-information ()
+ "Print a message with informations about the song currently playing"
+ (interactive)
+ (if media/current-information
+ (message "Now playing %s (%dHz, %s, %dkbit/s)"
+ (or (and (string= (car media/played-information) (nth 0 media/current-information))
+ (cdr media/played-information))
+ (replace-regexp-in-string "^.*/\\([^/]*\\)$" "\\1" (nth 0 media/current-information)))
+ (nth 1 media/current-information)
+ (if (= 2 (nth 2 media/current-information)) "stereo" "mono")
+ (nth 3 media/current-information))
+ (message "No song playing")))
+
+(defun media/save-and-kill-buffer ()
+ "Save the playlists and kill the media buffer"
+ (interactive)
+
+ (condition-case nil
+ (when media/add-current-song-to-interrupted-when-killing
+ (setq media/active-playlist "Interrupted")
+ (media/add-current-song-to-active-playlist t)
+ )
+ (error nil))
+
+ (unless (condition-case nil
+ (media/save-playlists)
+ (error (not (y-or-n-p "Can not save the playlists. Still kill the media buffer ? "))))
+ (kill-buffer media/buffer))
+ )
+
+(defun media/insert-keybindings (keymap)
+ (insert (format "media/insert-keybindings [%s]" (prin1-to-string keymap)))
+ (insert "\n---------------\n")
+ (if (listp keymap)
+ (if (eq (car keymap) 'keymap)
+ (mapc 'media/insert-keybindings (cdr keymap)))
+ (unless (eq (cdr keymap) 'undefined)
+ (insert (format "%s -> %s\n"
+ (prin1-to-string (car keymap))
+ (prin1-to-string (cdr keymap)))))
+ ))
+
+(defun media/show-keys (&optional keymap) (interactive)
+ (set-buffer (get-buffer-create "*media help*"))
+ (media/insert-keybindings media/mode-map))
+
+(defun media/quick-help () (interactive)
+ (message "<return> play <n> add to the queue <p> pause <m> continue mode <q> bury the buffer <k> kill it"))
+
+(defun media/move-forward () (interactive) (media/api/jump-at-time 'relative 3))
+(defun media/move-backward () (interactive) (media/api/jump-at-time 'relative -3))
+(defun media/volume-reset () (interactive) (media/api/set-volume 'absolute 50))
+(defun media/volume-increase () (interactive) (media/api/set-volume 'relative 1))
+(defun media/volume-decrease () (interactive) (media/api/set-volume 'relative -1))
+
+(defun media/mode () (interactive)
+ (if media/buffer (error "We already have a media buffer"))
+
+ (kill-all-local-variables)
+
+ (unless (boundp 'media/mode-map)
+
+ (setq media/mode-map (make-sparse-keymap))
+
+ (suppress-keymap media/mode-map)
+
+ (mapc (lambda (x) (define-key media/mode-map (car x) (cdr x)))
+ `(("p" . media/pause)
+ ("\C-m" . media/play-or-active-at-point)
+ ("\t" . media/goto-next-playlist-or-dir)
+ ([(shift iso-lefttab)] . media/goto-previous-playlist-or-dir)
+ (" " . media/goto-current)
+ ("a" . media/add-song-at-point-to-active-playlist)
+ ("A" . media/add-current-song-to-active-playlist)
+ ("n" . media/queue-song-at-point)
+ ("f" . media/show-id3-at-point)
+ ("r" . media/rename-point)
+ ("R" . media/rename-point-according-to-id3)
+ ("K" . media/move-point-to-tmp)
+ ("N" . media/play-next)
+ ("P" . media/play-prev)
+ ("q" . bury-buffer)
+ ("k" . media/save-and-kill-buffer)
+ ("s" . media/stop)
+ ("m" . media/switch-continue-mode)
+ ;; ("t" . media/switch-timing)
+ ("g" . media/refresh-list)
+ ("h" . media/quick-help)
+ ("?" . media/quick-help)
+ ("l" . media/select-active-playlist)
+ ;; ("L" . media/create-playlist)
+ ("i" . media/show-current-information)
+ ;; ("I" . media/edit-id3-at-point)
+ ("j" . media/jump-at-percent)
+ (">" . media/move-forward)
+ ("<" . media/move-backward)
+ ([(control >)] . (lambda () (interactive) (media/api/jump-at-time 'relative 30)))
+ ([(control <)] . (lambda () (interactive) (media/api/jump-at-time 'relative -30)))
+ ([(control x) (control s)] . media/save-playlists)
+ ("=" . media/volume-reset)
+ ("+" . media/volume-increase)
+ ("-" . media/volume-decrease)
+ )))
+
+ (setq major-mode 'media
+ mode-name "Media"
+ ;; buffer-read-only t
+ truncate-lines t
+ media/buffer (current-buffer)
+ media/current-overlay (make-overlay 0 0)
+ media/instant-highlight-overlay (make-overlay 0 0)
+ media/song-current-time nil
+ media/song-duration nil
+ global-mode-string (append global-mode-string '((:eval (media/mode-string))))
+ )
+
+ (overlay-put media/current-overlay 'face 'media/current-tune-face)
+ (overlay-put media/instant-highlight-overlay 'face 'media/instant-highlight-face)
+
+ (use-local-map media/mode-map)
+
+ (add-hook 'kill-emacs-hook 'media/die-decently)
+ (add-hook 'kill-buffer-hook 'media/kill-buffer-cleanup nil t)
+ (add-hook 'write-contents-hooks 'media/save-buffer nil t)
+ )
+
+(defun media/die-decently ()
+ (when media/add-current-song-to-interrupted-when-killing
+ (condition-case nil
+ (progn
+ (setq media/active-playlist "Interrupted")
+ (media/add-current-song-to-active-playlist t)
+ (media/save-playlists))
+ (error nil))
+ )
+ )
+
+(defun media/kill-buffer-cleanup () (interactive)
+ (media/api/cleanup)
+ (setq media/buffer nil
+ global-mode-string (remove '(:eval (media/mode-string)) global-mode-string))
+ )
+
+(defun media/full-refresh ()
+
+ (undo-boundary)
+ (erase-buffer)
+ (media/import media/url-list)
+ (media/goto-top)
+ (media/load-playlists)
+
+ (unless media/expert
+ (insert (propertize "
+ media.el
+ Written and (C) Francois Fleuret
+ Send comments and bug reports to francois@fleuret.org
+
+ Return play or active the playlist for insertion
+ Space goto song playing
+ p pause
+ g refresh list
+ a insert song at point to the active playlist
+ A insert current song to the active playlist
+ universal argument store the time too
+ l select active playlist
+ C-x C-s save playlists
+ n queue song for playing
+ f show ID3 of song
+ r rename song
+ R rename song according to ID3
+ K move song to /tmp
+ N play next
+ P play previous
+ q hide buffer
+ k stop song and kill buffer
+ s stop song
+ m switch the continuous mode
+ i show current song information
+ j jump at position
+ > fast forward
+ < fast backward
+ Ctrl-> fast forward x10
+ Ctrl-< fast backward x10
+ = reset volume
+ + increase volume
+ - decrease volume
+" 'prologue t)))
+
+ (set-buffer-modified-p nil)
+ (undo-boundary)
+ )
+
+(defun media/switch-to-buffer-or-window (buffer)
+ (let ((w (get-buffer-window buffer)))
+ (if w (select-window w)
+ (switch-to-buffer buffer))))
+
+(defun media ()
+ "If a `media/buffer' exists, and we are not in it, switch to it, if
+we are already in it, bury it. If none exists, creates one and switch
+to it."
+ (interactive)
+
+ (if media/buffer
+ (if (eq (window-buffer (selected-window)) media/buffer)
+ (bury-buffer)
+ (media/switch-to-buffer-or-window media/buffer))
+ (switch-to-buffer (get-buffer-create "*media*"))
+ (buffer-disable-undo)
+ (media/mode)
+ (media/full-refresh)
+ (buffer-enable-undo)
+ (run-hooks 'media/starting-hook)
+ )
+ )
+
+(load media/player-api)
+
+(media/api/init)
--- /dev/null
+;; -*- mode: emacs-lisp -*-
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; This program is free software; you can redistribute it and/or ;;
+;; modify it under the terms of the GNU General Public License as ;;
+;; published by the Free Software Foundation; either version 3, or (at ;;
+;; your option) any later version. ;;
+;; ;;
+;; This program is distributed in the hope that it will be useful, but ;;
+;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;
+;; General Public License for more details. ;;
+;; ;;
+;; You should have received a copy of the GNU General Public License ;;
+;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;
+;; ;;
+;; Written by and Copyright (C) Francois Fleuret ;;
+;; Contact <francois@fleuret.org> for comments & bug reports ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; The selector/select function provides a simple interface for
+;; selecting an object with on-the-fly pattern matching in a standard
+;; buffer (i.e. not in the minibuffer). You can either use it in your
+;; own functions or directly use selector/quick-pick-recent or
+;; selector/quick-move-in-buffer.
+;;
+;; For instance, you can add in your .emacs.el
+;;
+;; (require 'recentf)
+;; (recentf-mode 1)
+;;
+;; (when (load "selector" t t)
+;; (define-key global-map [(control x) (control r)] 'selector/quick-pick-recent)
+;; (define-key global-map [(control c) (control s)] 'selector/quick-move-in-buffer)
+;; (define-key global-map [(control x) (control b)] 'selector/switch-buffer)
+;; )
+
+(defgroup selector ()
+ "Major mode for selection of entries with dynamic pattern matching"
+ :version "1.2.3")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; User-configurable variables
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defcustom selector/memorize-entry-only-on-motions t
+ "If non-nil, only the cursor motions memorize the current selection.
+Restriction of the selection does not. This means that if you
+change the pattern and then edit it to cancel the change, the
+cursor will come back to its original location, unless you have
+explicitely moved it with the arrow keys at some point."
+ :type 'bool
+ :group 'selector)
+
+(defcustom selector/info-in-mode-line nil
+ "If nil, the pattern is shown in the menu header.
+Otherwise use the mode-line."
+ :type 'bool
+ :group 'selector)
+
+(defcustom selector/always-create-buffer nil
+ "If nil, re-use existing similar buffer when possible."
+ :type 'bool
+ :group 'selector)
+
+(defcustom selector/mode-hook nil
+ "Hook called at the end of the selector mode initialization."
+ :type 'hook
+ :group 'selector)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defface selector/selection
+ ;; '((t (:bold t)))
+ '((t (:background "chartreuse")))
+ "The face for the current selection.")
+
+(defface selector/dim
+ '((t (:foreground "gray70")))
+ "The face for dimmed entries.")
+
+(defface selector/date
+ '((t (:foreground "dark violet")))
+ "The face for the dates in selector/quick-pick-recent.")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar selector/pattern
+ ""
+ "The pattern to match to appear in the selector buffer.")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun selector/string-match-all (regexps string)
+ "Return if STRING matches all regular expressions in REGEXPS."
+ (if regexps
+ (and (string-match (car regexps) string)
+ (selector/string-match-all (cdr regexps) string))
+ t))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun selector/move-highlight-overlay ()
+ "Move the highlight overlay to highlight the current line."
+ (if (get-text-property (point) 'entry)
+ (move-overlay selector/highlight-overlay
+ (or (previous-single-property-change (1+ (point)) 'entry)
+ (point-min))
+ (or (next-single-property-change (point) 'entry)
+ (point-max)))
+ ;; (move-overlay selector/highlight-overlay 0 0)
+ (delete-overlay selector/highlight-overlay)
+ )
+
+ (unless (and selector/memorize-entry-only-on-motions
+ (memq this-command
+ '(selector/delete-backward-char
+ selector/self-insert-command)))
+ (setq selector/current-entry (get-text-property (point) 'entry)))
+ )
+
+(defun selector/refresh ()
+ "Erase and reconstruct the content of the current buffer
+according to `selector/entries' and `selector/pattern'."
+
+ (let ((inhibit-read-only t)
+ (pos (point))
+ (line-beginning (line-beginning-position))
+ (regexps (mapcar 'regexp-quote (split-string selector/pattern ";")))
+ (newpos (point))
+ (nb-shown-entries 0))
+
+ (erase-buffer)
+
+ (mapc (lambda (s)
+ (when (selector/string-match-all regexps (car s))
+ (setq nb-shown-entries (1+ nb-shown-entries))
+ (if (eq (cdr s) selector/current-entry)
+ (setq newpos (+ (- pos line-beginning) (point))))
+ (insert
+ (propertize (concat (car s) "\n")
+ 'entry (cdr s)
+ ;; 'face 'compilation-error
+ ))))
+ selector/entries)
+
+ (setq newpos (min newpos (point-max)))
+ (setq selector/nb-shown-entries (number-to-string nb-shown-entries))
+
+ (goto-char (or (and (get-text-property newpos 'entry) newpos)
+ (previous-single-property-change newpos 'entry)
+ (point-max)))
+
+ (beginning-of-line)
+ (force-mode-line-update)
+ ))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun selector/self-insert-command ()
+ "Insert the last pressed key at the end of `selector/pattern'."
+ (interactive)
+ (setq selector/pattern (concat selector/pattern
+ (this-command-keys)))
+ (selector/refresh)
+ )
+
+(defun selector/delete-backward-char ()
+ "Remove the last character of `selector/pattern'."
+ (interactive)
+ (when (> (length selector/pattern) 0)
+ (setq selector/pattern (substring selector/pattern 0 -1)))
+ (selector/refresh)
+ )
+
+(defun selector/kill-line ()
+ "Move the content of `selector/pattern' to the kill ring."
+ (interactive)
+ (kill-new selector/pattern t)
+ (setq selector/pattern "")
+ (selector/refresh))
+
+(defun selector/yank (&optional arg)
+ "Append the content of the kill ring to `selector/pattern'."
+ (interactive "P")
+ (setq selector/pattern (concat selector/pattern
+ (current-kill (cond
+ ((listp arg) 0)
+ ((eq arg '-) -2)
+ (t (1- arg))))))
+ (selector/refresh))
+
+(defun selector/return ()
+ "Call the function specified by `selector/callback' with the
+entry at point as parameter."
+ (interactive)
+ (let ((result (get-text-property (point) 'entry))
+ (callback selector/callback))
+ (kill-this-buffer)
+ (if result (funcall callback result)
+ (error "No selection"))))
+
+(defun selector/goto-next-entry ()
+ "Move point to the next entry."
+ (interactive)
+ (let ((n (or (next-single-property-change (point) 'entry)
+ (point-min))))
+ (if n (goto-char n))))
+
+(defun selector/goto-previous-entry ()
+ "Move point to the previous entry."
+ (interactive)
+ (let ((n (or (previous-single-property-change (point) 'entry)
+ (previous-single-property-change (point-max) 'entry))))
+ (if n (goto-char n))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun selector/mode ()
+ "Mode for selection of strings. See `selector/select' for a
+detailed explanation."
+
+ (unless (boundp 'selector/map)
+ (setq selector/map (make-sparse-keymap))
+
+ (mapc (lambda (p)
+ (substitute-key-definition (car p)
+ (cdr p)
+ selector/map global-map)
+ )
+
+ ;; What are the functions to substitute by what
+ '((self-insert-command . selector/self-insert-command)
+ (delete-backward-char . selector/delete-backward-char)
+ (kill-line . selector/kill-line)
+ (yank . selector/yank)
+ (newline . selector/return)
+ ;; (keyboard-quit . kill-this-buffer)
+ ))
+
+ (define-key selector/map "\C-g"
+ 'kill-this-buffer)
+
+ (define-key selector/map (kbd "TAB")
+ 'selector/goto-next-entry)
+
+ (define-key selector/map [(shift iso-lefttab)]
+ 'selector/goto-previous-entry)
+
+ )
+
+ (setq major-mode 'selector/mode
+ mode-name "Selector"
+ buffer-read-only t
+ )
+
+ (set
+ (if selector/info-in-mode-line 'mode-line-format 'header-line-format)
+ '(" " selector/nb-shown-entries "/"
+ selector/nb-total-entries " pattern: " selector/pattern)
+ )
+
+ (buffer-disable-undo)
+ (use-local-map selector/map)
+ (run-hooks 'selector/mode-hook)
+ )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun selector/select (entries callback &optional name)
+ "Open a new buffer showing dynamically a subset of entries
+matching a pattern that can be changed by pressing the usual
+\"insertable\" symbols or backspace. Pressing the enter key
+validates the selection.
+
+Note that the pattern is not a regexp but a series of substrings
+separated by `;'s that have all to be present.
+
+The key mapping is hacked so that the keys associated to
+`self-insert-command', `delete-backward-char', `kill-line',
+`yank' and `newline' are associated to functions which do somehow
+what they are supposed to do. The latter validating the
+selection.
+
+ENTRIES is a list of cons cells, each composed of a string to
+display and an object to pass as the unique parameter to CALLBACK
+when the user actually does a selection. The optional NAME
+parameter specifies the name to give to the buffer.
+
+Setting `selector/memorize-entry-only-on-motions' to non-nil
+means that the entry to keep the cursor on when changing the
+selection is set only on cursor motions. To show the pattern in
+the modeline set `selector/info-in-mode-line'. The header line is
+used by default. To always open a new buffer and not re-use an
+existing buffer with the same name, set
+`selector/always-create-buffer' to non-nil.
+
+There seems to be header-line refreshing problems with emacs21."
+
+ (switch-to-buffer
+ (get-buffer-create
+ (funcall
+ (if selector/always-create-buffer 'generate-new-buffer-name 'identity)
+ (or name "*selector*"))))
+
+ (set (make-local-variable 'selector/entries) entries)
+ (set (make-local-variable 'selector/callback) callback)
+ (set (make-local-variable 'selector/pattern) "")
+ (set (make-local-variable 'selector/highlight-overlay) (make-overlay 0 0))
+ (set (make-local-variable 'selector/current-entry) nil)
+ (set (make-local-variable 'selector/nb-total-entries)
+ (number-to-string (length entries)))
+ (set (make-local-variable 'selector/nb-shown-entries) "?")
+
+ (overlay-put selector/highlight-overlay 'face 'selector/selection)
+
+ (add-hook 'post-command-hook 'selector/move-highlight-overlay nil t)
+ (selector/mode)
+ (selector/refresh)
+ )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; To open recent files
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun selector/filename-to-string (filename)
+ "Generate the line associated to a filename for `selector/quick-pick-recent'"
+ (concat
+ " "
+ (if (file-remote-p s)
+ " "
+ (propertize
+ (format-time-string "%a %b %e" (elt (file-attributes s) 5))
+ 'face 'selector/date))
+
+ " -- "
+
+ (if (string-match abbreviated-home-dir s)
+ (concat (propertize
+ (substring s 0 (match-end 0)) 'face 'selector/dim)
+ (substring s (match-end 0)))
+ s)
+ )
+ )
+
+(defun selector/find-file (filename)
+ "Callback function for `selector/quick-pick-recent'. When
+called with a universal argument, allows the user to edit the
+filename."
+ (interactive)
+ (if current-prefix-arg
+ (find-file (read-file-name
+ "Find file: "
+ (file-name-directory filename)
+ nil
+ nil
+ (file-name-nondirectory filename)))
+ (find-file filename)))
+
+(defun selector/quick-pick-recent ()
+ "Open a file picked in `recentf-list' with the dynamic
+pattern-matching search implemented in `selector/select'. With a
+prefix argument, allows to edit the filename after selection."
+ (interactive)
+
+ (unless (and (boundp recentf-mode) recentf-mode)
+ (error "recentf mode must be turned on"))
+
+ (selector/select
+
+ (mapcar
+ (lambda (s)
+ (cons (selector/filename-to-string s) s))
+ recentf-list)
+
+ 'selector/find-file
+ "*selector find-file*"
+ ))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; To search in the current buffer
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun selector/quick-move-in-buffer ()
+ "Move the cursor in the current buffer to a line selected
+dynamically with `selector/select'."
+ (interactive)
+ (selector/select
+ (reverse
+ (let ((l nil))
+ (save-excursion
+ (goto-char (point-min))
+ (while (< (point) (point-max))
+ (setq l (cons (cons (buffer-substring (point-at-bol) (point-at-eol))
+ (point-at-bol)) l))
+ (forward-line 1))
+ l))
+ )
+ 'goto-char
+ "*selector buffer move*"
+ ))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; To switch between buffers
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun selector/switch-buffer () (interactive)
+ "Select the current buffer dynamically with `selector/select'."
+ (interactive)
+ (selector/select
+ (let ((l nil))
+ (mapc
+ (lambda (buffer)
+ (with-current-buffer buffer
+ (let ((name (buffer-name))
+ (size (buffer-size))
+ (file (buffer-file-name))
+ (modified (buffer-modified-p)))
+ (when (not (string-match "^ +" name))
+ (push
+ (cons
+ (replace-regexp-in-string
+ " +$"
+ ""
+ (format
+ "% 8d %s %-30s%s"
+ size
+ (if modified "*" "-")
+ name
+ (if file (concat
+ (replace-regexp-in-string abbreviated-home-dir
+ "~/" file)
+ ) "")
+ ))
+ buffer)
+ l)
+ ))))
+ (reverse (buffer-list)))
+ l)
+ 'switch-to-buffer
+ "*selector switch-buffer*"
+ ))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; To search among sentences (i.e. between periods, not between \n)
+;; This is work in progress, it currently looks kind of ugly but is
+;; already useful to navigate in a long article
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun selector/search-sentence ()
+ "Move the cursor to a sentence chosen dynamically with
+`selector/select'."
+ (interactive)
+ (selector/select
+ (let ((sentences nil))
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward "[^.]+\\." nil t)
+ (let ((s (replace-regexp-in-string "^[ \n]+" ""
+ (match-string-no-properties 0)))
+ (p (match-beginning 0)))
+ (setq s (replace-regexp-in-string "[ \n]+$" "" s))
+ (when (> (length s) 1)
+ (push (cons
+ (with-temp-buffer
+ (insert s "\n")
+ (fill-region (point-min) (point-max))
+ (buffer-string))
+ p) sentences)))))
+ (reverse sentences))
+ 'goto-char))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defface selector/dir
+ '((t (:foreground "red")))
+ "The face for directories.")
+
+(defface selector/symlink
+ '((t (:foreground "blue")))
+ "The face for symlinks.")
+
+(defun selector/rec-find-file (&optional filename) (interactive)
+ (setq filename (or filename
+ (and (buffer-file-name) (file-name-directory (buffer-file-name)))
+ default-directory))
+
+ (if (file-regular-p filename) (find-file filename)
+ (selector/select
+ (mapcar
+ (lambda (file)
+ (let ((f (car file)))
+ (cons
+ (if (file-regular-p f)
+ f
+ (if (file-symlink-p f)
+ (propertize f 'face 'selector/symlink)
+ (propertize f 'face 'selector/dir)))
+ (concat filename "/" f))))
+ (directory-files-and-attributes filename))
+ 'selector/rec-find-file
+ (concat "selector " filename)
+ )))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
projects / elisp.git / commitdiff