From: Francois Fleuret Date: Sun, 28 Feb 2010 09:57:57 +0000 (+0100) Subject: Initial commit X-Git-Url: https://fleuret.org/cgi-bin/gitweb/gitweb.cgi?a=commitdiff_plain;h=3771096a125c7cff7216ca61ce51b2cda5a7aca1;p=elisp.git Initial commit --- 3771096a125c7cff7216ca61ce51b2cda5a7aca1 diff --git a/alarm-vc.el b/alarm-vc.el new file mode 100644 index 0000000..492a862 --- /dev/null +++ b/alarm-vc.el @@ -0,0 +1,117 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; 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 . ;; +;; ;; +;; Written by and Copyright (C) Francois Fleuret ;; +;; Contact 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)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/enotes.el b/enotes.el new file mode 100644 index 0000000..8f806b3 --- /dev/null +++ b/enotes.el @@ -0,0 +1,1249 @@ + +;; -*-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 . ;; +;; ;; +;; Written by and Copyright (C) Francois Fleuret ;; +;; Contact 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 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 ]*" "" + (replace-regexp-in-string "\n\\([^\n]+\\)" + "\n \\1" + (concat info ""))) + '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))))))) +;; ) diff --git a/lookup-dict.el b/lookup-dict.el new file mode 100644 index 0000000..e89c237 --- /dev/null +++ b/lookup-dict.el @@ -0,0 +1,111 @@ +;; -*-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 . ;; +;; ;; +;; Written by and Copyright (C) Francois Fleuret ;; +;; Contact 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 to go one page down, 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) + ) + + ))) diff --git a/media-mplayer.el b/media-mplayer.el new file mode 100644 index 0000000..da6d8df --- /dev/null +++ b/media-mplayer.el @@ -0,0 +1,296 @@ +;; -*-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 . ;; +;; ;; +;; Written by and Copyright (C) Francois Fleuret ;; +;; Contact 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 ]+" 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") + ) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/media.el b/media.el new file mode 100644 index 0000000..c94491c --- /dev/null +++ b/media.el @@ -0,0 +1,1139 @@ +;; -*-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 . ;; +;; ;; +;; Written by and Copyright (C) Francois Fleuret ;; +;; Contact 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 + "[ ]*$" "" + (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 "")))))))) + +(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 " play add to the queue

pause continue mode bury the buffer 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) diff --git a/selector.el b/selector.el new file mode 100644 index 0000000..17a5b23 --- /dev/null +++ b/selector.el @@ -0,0 +1,505 @@ +;; -*- 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 . ;; +;; ;; +;; Written by and Copyright (C) Francois Fleuret ;; +;; Contact 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) + ))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;