;; -*- mode:emacs-lisp; mode: outline-minor -*-
;;
;; RCSfile: Rtrinkets.el,v
;; Revision: 1.9
;; Date: 1998/09/29 04:36:57
;;
;; NAME
;; Rtrinkets -- miscellaneous emacs code
;;
;; LICENSE
;; This source code is hereby released to the public domain and is unsupported.
;; You are encouraged to copy and modify this file.  Please clearly document
;; modifications with authorship and motivation.  Bug reports, code
;; contributions, and suggestions are appreciated.
;; 
;; SOURCE
;; New versions of this file may be obtained from (as of 1998/11/08)
;; http://www.in-machina.com/~reece/emacs/Rtrinkets.el
;; ftp://in-machina.com/pub/reece/emacs/Rtrinkets.el
;; 
;; AUTHOR
;; Reece Hart, http://www.in-machina.com/~reece/, PGP:0xD178AAF9
;; Do not send unsolicited bulk email.  Boycott companies which do so.
;; 

(defconst Rtrinkets-version (substring "Revision: 1.9" 11 -2))
(defconst bar (make-string 80 45))          ; 45 == '-'

(defvar prefix-function-name t
  "Prefix errors and messages with function name in which they originate.")

(defun a2ps-buffer ()
  "print the entire buffer using a2ps-region.  See that for more info."
  (interactive)
  (a2ps-region (point-min) (point-max) (buffer-name)))

(defun a2ps-region (start end &optional header)
  "print the current region using a2ps; no errors are caught"
  (interactive "r")
  (let*
      ((command (concat "a2ps -8 -B -v"
                        " -t" tab-width
                        " '-H" (if header
                                   header
                                 (concat "excerpt of " (buffer-name))) "'"
                                 " >/dev/null 2>&1"))
       (shell-file-name "/bin/sh")
       )
    (shell-command-on-region start end command nil)
    (message command)
    ))

(defun add-to-load-path (elems)
  "Prepend elems (list or symbol) to load-path if not already there."
  (setq load-path (prepend-if-not-member elems load-path)))

(defun banner (PFX TEXT)
  (interactive "s1:\ns2:")
  (shell-command (concat "banner " TEXT "|sed -e 's/^/" PFX "/'") t))

(defvar citation-labels nil
  "Available citation labels.  Set it by visiting a bibtex buffer and eval'ing
 (setq citation-labels (citation-collect-labels))")

(defun bibtex-collect-labels ()
  "(bibtex-collect-labels)
Returns an alist of the bibtex labels in the current buffer.  This list is
suitable for passing to completing-read, for instance."
  (let* (label
         labels
         (case-fold-search t))
    (save-excursion
      (goto-char (point-min))
      (while
          (re-search-forward
           "\\(^@[a-z]+[ \t\n]*[{(][ \t\n]*\\([^ ,\t\n]+\\)[ \t\n]*,\\)\\|\\(^[ \t\n]*crossref[ \t\n]*=[ \t\n]*[{\"]\\([^ ,\t\n]*\\)[}\"],$\\)"
           nil t)
        (if (match-beginning 2)
            (setq label (buffer-substring (match-beginning 2) (match-end 2)))
          (setq label (buffer-substring (match-beginning 4) (match-end 4))))
        (if (not (assoc label labels))
            (setq labels (cons (list label) labels)))))
    labels))

(defun buffer-revisit-as (FILE &optional WARP)
  "buffer-revisit-as-file (FILE)
Change the filename that the current buffer is visiting to FILE.  If
FILE is already being visited by another buffer, then kill this buffer
and go there if WARP is t, otherwise error.  The buffer name is
returned.  A buffer's visiting file comparison is based upon the
actual file being modified after chasing links."
  (interactive)
  (if (string= FILE (buffer-file-name))
      ;; then
      (buffer-name)
    ;; else
    (let ((visiting-same-file (find-buffer-visiting FILE))
          (buffer-modified (buffer-modified-p)))
      
      (if (and visiting-same-file
               (not (string= (buffer-name) (buffer-name visiting-same-file))))
          (if WARP
              (progn
                (kill-buffer (buffer-name))
                (switch-to-buffer visiting-same-file)
                (buffer-name visiting-same-file)
                )
            
            (error "%sbuffer %s already visiting %s"
                   (if prefix-function-name "buffer-revisit-as: " "")
                   (buffer-name visiting-same-file)
                   FILE
                   )
            )                               ;fi WARP
        ;; else
        (progn
          (set-visited-file-name FILE)
          (set-buffer-modified-p buffer-modified)
          (buffer-name))
        )                                   ;fi
      )
    )
  )

(defun citation-insert (&optional LABEL)
  (interactive)
  (let* ((citation-backward-search-limit 50)
         (citation-forward-search-limit 50)
         (completion-ignore-case t)
         ;; determine the bounds of the current citation list if we're in one
         ;; o is where we started; b is the [ to our left or nil if none (within
         ;; citation-backward-search-limit); e is ] to our right or nil.
         (o (point))
         (e (+ o (skip-chars-forward "^[]" (+ o citation-forward-search-limit))))
         (e (if (= (following-char) (string-to-char "]")) e nil))
         (b (+ o (skip-chars-backward "^[]" (- o citation-backward-search-limit))))
         (b (if (= (preceding-char) (string-to-char "[")) b nil))
         ;; get label to be inserted if not supplied as argument
         (labels (or citation-labels (bibtex-collect-labels)))
         (label (if LABEL
                    (if (not (assoc LABEL labels))
                        (error "Can't insert %s: No such citation!" LABEL)
                      LABEL)
                  (completing-read "Citation label: " labels nil t)))
         ) ;; variables of let*
    (cond
     ((and b e (<= b e))
      ;; inside a citation list delimited by [].  The point is at the first
      ;; character inside the [ (left there by re-backward-search).
      ;; skip across the citations to find the appropriate place to insert
      (while (and (not (looking-at "]"))
                  (citation-label<
                   (progn (looking-at "\\([^],]*\\)") (match-string 1))
                   label)
                  )
        (skip-chars-forward "^],")
;       (if (not (looking-at "]")) (skip-chars-forward ", "))
        (if (not (= (following-char) (string-to-char "]")))
            (skip-chars-forward ", "))
        )
      ;; 4 cases inserting into an existing list: insert in a 1) null list
      ;; or at the 2) start, 3) middle, or 4) end of a non-null list.
      (if (string= 
           label
           (progn (looking-at "\\([^],]*\\)") (match-string 1)))
          (error "%sCitation `%s' already in list!"
                 (if prefix-function-name "citation-insert: " "")
                 label
                 )
        (insert
         (if (not (save-excursion (re-search-backward "[[, ]" (- (point) 2) t)))
             ", " "")
         label
         (if (not (= (following-char) (string-to-char "]")))
             ", " "")
         )
        )
      )

     (t
      ;; outside a [] pair
      (goto-char o)
      (insert "[" label "]")
      )

     )
    )
  )

(defun citation-label< (L1 L2)
  "(citation-label< L1 L2)
returns t if label L1 should appear before label L2 in a citation list.  The
comparison orders more recent articles first, then alphabetically for articles
in the same year.  Labels usually have the form NameYear; labels without Year
are sorted to the end of the list."
  (let* ((labelre "\\([^0-9]*\\)\\([0-9]*\\)")
         (A1 (progn (string-match labelre L1) (match-string 1 L1)))
         (Y1 (string-to-int (match-string 2 L1)))
         (A2 (progn (string-match labelre L2) (match-string 1 L2)))
         (Y2 (string-to-int (match-string 2 L2)))
         )
    (or (> Y1 Y2)
        (and (= Y1 Y2) (string< A1 A2)))
    )
  )

(defun cut-here ()
  "Insert a delineate a form which follows."
  (interactive)
  (insert-file-contents "~reece/notes/scissors"))

(defun delete-frame-or-kill-emacs (&optional prefix-arg)
  "Deletes the current frame.  Also kills Emacs if there's only one
   frame left.  Optional prefix PREFIX-ARG is passed to save-buffers-kill-emacs
   if that function is called, otherwise PREFIX-ARG is ignored."
  (interactive "P")
  (if (= 1 (length (frame-list)))
      (save-buffers-kill-emacs prefix-arg)
    (delete-frame)))

(defun dir-read-write-p (path)
  "return t if path exists, is an accessible directory, and is
writable; otherwise nil"
  (and path (file-accessible-directory-p path) (file-writable-p path)))

(defun dired-with-buffer-name (BUFNAME DIRNAME &optional SWITCHES)
  (interactive)
  (dired DIRNAME)
  (rename-buffer BUFNAME t)
  )
(defun dired-home ()
 (interactive)
 (if (get-buffer "~")
     (switch-to-buffer "~")
   (dired-with-buffer-name "~" "~/[^.]*")))

(defun dissociate-buffer-from-file ()
  "Dissociates buffer from its visited file so that changes will not be
saved.  This allows files to be used as templates easily and without
making the file read only."
  (interactive)
  (set-visited-file-name nil))

(defun dot-dot-dot ()
  "Vertical elipsis in text to indicated deleted region."
  (interactive)
  (insert "  .\n  . [text deleted]\n  .\n"))

(defun duat ()
  "start a telnet session to duat"
  (interactive)
  (telnet "duat.gtefsd.com")
)

(defun exclude-region (start end)
  "Comment out a region with a #if 0/#endif pair."
  (interactive "r")
  (goto-char end)
  (beginning-of-line)
  (insert "#endif\n")
  (goto-char start)
  (beginning-of-line)
  (insert "#if 0\n")
  (goto-char end)
  (next-line 2))

(defun file-contents-as-string (FILE &optional BEG END)
  "Return the contents of FILE, between BEG and END (see
insert-file-contents for description)."
  (if (not (file-readable-p FILE))
      (error "%s not readable" FILE))
  (let ((buf (generate-new-buffer " fcas"))
        bs
        beg
        end)
    (set-buffer buf)
    (insert-file-contents FILE nil BEG END)
    (setq bs (buffer-substring (point-min) (point-max)))
    (kill-buffer buf)
    bs))

; This function is deprecated in favor of dired-x-find-file
(defun filename-near-point ()
  "Return the filename of an existing file near the point, nil if unable."
  (interactive)
  (let
      ((filename (save-excursion
                  (if (string-match (char-to-string (char-after (point))) "[     ]")
                      (progn 
                        (skip-chars-backward "   " (current-column)) ; spc,tab
                        (if (= (current-column) 0)
                            (skip-chars-forward "    ") ; spc,tab
                          (backward-char))))
                   (thing-at-point 'filename))))
    (if (file-exists-p filename)
        filename)))

; This function is deprecated in favor of dired-x-find-file
(defun find-file-in-context (other-window)
  "Try to find the file near the current point.  First try literal filname
 (as with filename-near-point) or with heuristics (ff-find-other-file)"
  (interactive "P")
  (if (filename-near-point)
      (find-file-near-point other-window)
    (ff-find-other-file)))

; This function is deprecated in favor of dired-x-find-file
(defun find-file-near-point (other-window)
  "find-file on the filename near the point, if able.  With prefix arg,
use other window."
  (interactive "P")
  (let ((filename (filename-near-point)))
    (if filename
        (if other-window
            (find-file-other-window filename)
          (find-file filename))
      (error "No file at point"))))

; This function is deprecated in favor of dired-x-find-file
(defun generate-new-buffer-name-from-file-name (FILE)
  "generate-new-buffer-name-from-file-name (FILE)
Return a reasonable name for a buffer given the visiting file name
using generate-new-buffer-name which see."
  (generate-new-buffer-name
   (let ((basename (file-name-nondirectory FILE)))
     (if (string= basename "")
         (abbreviate-file-name FILE)
       basename))))
(defvar fortune-cmd "cookie"
  "Command used to generate a fortune")

(defun insert-fortune ()
  "Insert a fortune using the command specified by fortune-cmd."
  (interactive)
  (shell-command fortune-cmd t)
  )

(defvar ph-flags "-fall")
(defun ph-lookup (QUERY)
  (interactive "sph query string: ")
  (shell-command
   (concat "ph " ph-flags " " QUERY)
   (or (get-buffer "*ph*")
       (or (generate-new-buffer "*ph*")))))
  
(defun prepend-if-not-member (elems list)
  "Prepends each of the elements of elems (either a list or a symbol)
to list, returning the result"
  (cond
   ((null elems)                            ; null element
    list)

   ((listp elems)                           ; elems is a list
      (append (prepend-if-not-member        ; process each car in turn
               (car elems)
               (prepend-if-not-member (cdr elems) list))))

   ((member elems list)                     ; elems already there
   list)                                    ; don't add it
    
   (t                                       ; otherwise prepend it
    (append (list elems) list))
   ))

(defun rewrite-date (date-string)
"Convert dates to a common format. e.g.,
Mon, 4 Dec 1995 13:21:59 -0600 (CST)  -> 1995 Dec 04 (Mon) 13:21:59 -0600 (CST)
Mon,  4 Dec 1995 13:21:59 -0600 (CST) -> 1995 Dec 04 (Mon) 13:21:59 -0600 (CST)
Mon 4 Dec 1995 13:21:59 -0600 (CST)   -> 1995 Dec 04 (Mon) 13:21:59 -0600 (CST)
Mon, 04 Dec 1995 13:21:59 -0600 (CST) -> 1995 Dec 04 (Mon) 13:21:59 -0600 (CST)
Mon, 4 Dec 1995 13:21:59 -0600        -> 1995 Dec 04 (Mon) 13:21:59 -0600 
Mon, 4 Dec 1995 13:21:59 (CST)        -> 1995 Dec 04 (Mon) 13:21:59 (CST)
Mon, 4 Dec 1995 13:21:59              -> 1995 Dec 04 (Mon) 13:21:59 
Tue,  5 Dec 95 17:21:44 -600          -> 1995 Dec 05 (Tue) 17:21:44 -0600
"
   (if (string-match "^\\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\|\\),?[ ]?\\([0-9 ][0-9]?\\) \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|Dec\\) \\(1?9?9[5-9]\\) \\([0-9][0-9]:[0-9][0-9]:[0-9][0-9]\\)[ ]?\\([+-]\\)?\\([0-9][0-9][0-9][0-9]?\\|\\)?[ ]?(?\\([A-Z][A-Z][A-Z]\\|\\))?$" date-string)
       (concat
        (let ((year (string-to-int (match-string 4 date-string))))
          (if (> year 1900) year (+ 1900 year))) " "
        (match-string 3 date-string) " "
        (format "%02d " (string-to-int (match-string 2 date-string)))
        (if (match-string 1 date-string)
            (concat "(" (match-string 1 date-string) ") "))
        (match-string 5 date-string) " "
        (if (not (string-equal (match-string 7 date-string) "")) ; TZ
            (concat (match-string 6 date-string) ; sign
                    (format "%04d " (string-to-int ; value
                                    (match-string 7 date-string)))))
        (if (not (string-equal (match-string 8 date-string) "")) ; TZ
            (concat "("
                    (match-string 8 date-string)
                    ")"))
        )
     )
   )
; test for rewrite-date
;(setq dates (list "Mon, 4 Dec 1995 13:21:59 -0600 (CST)"
;                 "Mon,  4 Dec 1995 13:21:59 -0600 (CST)"
;                 "Mon 4 Dec 1995 13:21:59 -0600 (CST)"
;                 "Mon, 04 Dec 1995 13:21:59 -0600 (CST)"
;                 "Mon, 4 Dec 1995 13:21:59 -0600"
;                 "Mon, 4 Dec 1995 13:21:59 (CST)"
;                 "Mon, 4 Dec 1995 13:21:59"
;                 "Tue,  5 Dec 95 17:21:44 -600"))
;(insert (mapcar (function (lambda (d) (insert (format "\n;%-37s -> %s" d (sc-rewrite-date d))))) dates))

(defun revert-buffer-noconfirm ()
  "Revert a buffer without confirmation"
  (interactive)
  (revert-buffer t t))

(defun sign-document ()
  "Sign document at end of buffer."
  (interactive)
  (save-excursion
    (end-of-buffer)
    (insert "--\n")
    (insert-file-contents "~/.signature")))

(defun tab-width-8-local ()
  "make current buffer only tab width 8"
  (interactive)
  (make-local-variable 'tab-width)
  (set-variable 'tab-width 8)
  )

(defun tmpdir ()
"Returns a valid directory into which temporary files may be written, or
nil if unable to find such a directory.  The search order is TMPDIR
 (environment variable), `/tmp', `.'; then failure.  See tmpfn.
reece@in-machina.com"
  (interactive)
  (let ((dirs (list (getenv "TMPDIR") "/tmp" ".")))
    (while (and (car dirs) (not (dir-read-write-p (car dirs))))
      (setq dirs (cdr dirs)))
    (car dirs)
    )
  )

(defun tmpfn (&optional prefix create tmpdir)
"tmpfn (&optional prefix create tmpdir)
Returns the full path of a valid temporary file. The filename is
created by concatenating tmpdir, prefix, and a random number until a
unique name is found.  If prefix is nil, it defaults to `tmpfn'.  If
tmpdir is nil, it defauls to the result returned by (tmpdir).  If
create is t, then the file created (with zero size and permissions
according to the current umask) to prevent subsequent calls to tmpfn
from returning the same name.  In the rare event that there are
1000000 files with names of this form, this function will fail to
return.  See tmpdir.
reece@in-machina.com"
  (if tmpdir
      (if (not (dir-read-write-p tmpdir))
          (error
           (format "tmpfn: %s nonexistant or incorrect permissions" tmpdir)))
    (if (not (setq tmpdir (tmpdir)))
        (error "tmpfn: can't find a valid directory for temporary files.  See tmpdir.")))
  (let ((path-prefix (concat tmpdir "/" 
                             (if prefix prefix "tmpfn") "-"))
        (fn))
    (while (or (not fn) (file-exists-p fn))
      (setq fn (format "%s%06d" path-prefix (random 999999)))
      )
    (if create (write-region 1 1 fn))
    fn)
  )

(defun untabify-message ()
  "untabify body of message before sending"
  (interactive)
  (save-excursion
    (goto-char (point-min))
    (search-forward-regexp "^---" (point-max) t)
    (next-line 1)
    (beginning-of-line)
    (let ((beg (point)))
      (goto-char (point-max))
      (untabify beg (point))
      )
    )
  )

(defun wrap-region (start end)
  "Wrap a region with lines which delineate included text."
  (interactive "r")
  (goto-char end)
  (beginning-of-line)
  (insert-file-contents "~reece/notes/wrap" nil 81 162) ; 162-81=80 chars + return
  (goto-char start)
  (beginning-of-line)
  (insert-file-contents "~reece/notes/wrap" nil 0 81) ; 80 chars + return
  (goto-char end)
  (next-line 2))

(provide 'Rtrinkets)