;;
;; Miscellaneous emacs-lisp functions
;;
;; $Id: qfuncs.el,v 1.86 1998/11/15 14:41:31 ejb Exp $
;; $Source: /home/ejb/elisp/q/RCS/qfuncs.el,v $
;; $Author: ejb $
;;


(defvar q-cc-style 
  '("Q"
    (c-basic-offset . 4)
    (c-comment-only-line-offset . 0)
    (c-offsets-alist
     (defun-block-intro . +)
     (block-open . 0)
     (substatement-open . 0)
     (knr-argdecl-intro . 2)
     (statement-cont . +)
     (case-label . +2)
     (access-label . -2)
     (statement-case-intro . +2)
     (statement-case-open . +2)
    )
  )
  "*cc-mode Style for Q's C++ indentation preference"
)

(defun qfuncs-init ()
  "Perform initialization that must be run after this file is loaded"
  (if (not (fboundp 'set-frame-name))
      (fset 'set-frame-name (symbol-function 'q-set-frame-name))
  )
)

(defun warp-to-qxterm ()
  "Warp to the place on the screen where the qxterm window goes"
  (interactive)
  (call-process "warpto" nil nil nil "484" "1142"))

(defun fill-cnews-sys ()
  "Neaten up a Cnews sys entry"
  (interactive)
  (let (beg end)
    (save-excursion
      (save-restriction
	(re-search-backward "^[a-z]+:")
	(setq beg (point))
	(re-search-forward "^\\s-*\n")
	(setq end (- (match-beginning 0) 1))
	(narrow-to-region beg end)
	(tabify beg end)
	(goto-char beg)
	(replace-string ",\\" "")
	(goto-char beg)
	(replace-string "," " ")
	(goto-char beg)
	(replace-string "\\t" "")
	(goto-char beg)
	(replace-string " " "\n")
	(goto-char beg)
	(let ((fill-column 77))
	  (fill-region (point-min) (point-max)))
	(goto-char beg)
	(save-excursion
	  (save-restriction
	    (forward-line 1)
	    (backward-char 1)
	    (narrow-to-region (point-min) (point))
	    (goto-char (point-min))
	    (replace-string " " ",")
	    (goto-char (point-max))
	    (insert ",\\")))
	(forward-line 1)
	(narrow-to-region (point) (point-max))
	(let ((fill-column 69))
	  (fill-region (point-min) (point-max)))
	(goto-char (point-max))
	(backward-char 1)
	(delete-region (point) (+ 1 (point)))
	(goto-char (point-min))
	(replace-regexp "^" "	")
	(goto-char (point-min))
	(replace-string " " ",")
	(goto-char (point-min))
	(replace-regexp "$" ",\\\\")
	(goto-char (point-max))
	(backward-char 2)
	(delete-region (point) (point-max))
	))))

(defun incnum (n)
  "Replace the next number in the buffer with n more than that number.
The value of n is the prefix arg or 1 if no prefix is given."
  (interactive "P")
  (let (s l i)
    (if (null n)
	(setq n 1)
      (if (listp n)
	  (setq n (car n))))
    (if (re-search-forward "[0-9]+" nil t)
	(progn
	  (goto-char (match-beginning 0))
	  (setq s (buffer-substring (point) (match-end 0)))
	  (delete-char (setq l (length s)))
	  (setq s (int-to-string (+ n (string-to-int s))))
	  (if (and (< (length s) l)
		   (string-match "^[0-9]" s))
	      (let ((i (- l (length s))))
		(while (> i 0)
		  (setq i (1- i))
		  (setq s (concat "0" s))
		  )
		)
	    )
	  (insert s)
	  )
      )
    )
  )

(defun new-ps (dirname)
  "Start a new problem set file and load in template."
  (interactive "DEnter directory: ")
  (let (filename num)
    (save-excursion
      (let (buf numstart numend)
	(set-buffer (setq buf (create-file-buffer "*new-ps*")))
	(setq dirname (expand-file-name dirname))
	(call-process "ls" nil t nil dirname)
	(goto-char (point-max))
	(if (re-search-backward "^ps\\([0-9][0-9]*\\)\\(\\.\\)tex" nil t)
	    (progn
	      (setq numstart (match-beginning 1))
	      (setq numend (match-beginning 2))
	      (setq num (buffer-substring numstart numend))
	      )
	  (setq num "0"))
	(kill-buffer buf)
	(setq num (int-to-string (+ 1 (string-to-int num))))
	(if (not (equal (substring dirname -1 nil) "/"))
	    (setq dirname (concat dirname "/")))
	(setq filename (concat dirname "ps" num ".tex"))
	))
    (find-file filename)
    (if (= (point-min) (point-max))
	(progn
	  (insert-file "template.tex")
	  (goto-char (point-min))
	  (search-forward "\psinit{")
	  (insert num)
	  (search-forward "{")))))


(defun overwrite-space (n)
  "Write a space over the current character"
  (interactive "P")
  (if (null n)
      (setq n 1)
    (if (listp n)
	(setq n (car n))))
  (let ((i n))
    (while (> i 0)
      (insert " ")
      (setq i (1- i))))
  (delete-char n))

(defun noop () "Do nothing" (interactive) nil)
(defun rmail-dialup ()
  "Disable keys so that rmail can be used over a noisy dialup line."
  (interactive)
  (local-set-key "a" 'noop)
  (local-set-key "." 'noop)
  (local-set-key "e" 'noop)
  (local-set-key "s" 'noop)
  (local-set-key "q" 'noop)
  (local-set-key "m" 'noop)
  (local-set-key "c" 'noop)
  (local-set-key "r" 'noop)
  (local-set-key "f" 'noop)
  (local-set-key "o" 'noop)
  (local-set-key "i" 'noop)
  (local-set-key "a" 'noop)
  (local-set-key "k" 'noop)
  (local-set-key "t" 'noop)
  (local-set-key "w" 'noop)
  (local-set-key "[" 'noop)
  (local-set-key "]" 'noop)
  (local-set-key "{" 'noop)
  (local-set-key "}" 'noop)
  (local-set-key "_" 'noop)
  (local-set-key "~" 'noop)
  (local-set-key "x" 'noop)
  (local-set-key "D" 'noop)
  (local-set-key "R" 'noop)
  (local-set-key "0" 'noop)
  (local-set-key "1" 'noop)
  (local-set-key "2" 'noop)
  (local-set-key "3" 'noop)
  (local-set-key "4" 'noop)
  (local-set-key "5" 'noop)
  (local-set-key "6" 'noop)
  (local-set-key "7" 'noop)
  (local-set-key "8" 'noop)
  (local-set-key "9" 'noop)
  (local-set-key "0" 'noop)
)

(defvar obj-file-prefix "" "*Prefix for converting source path to object")

(defun replace-file-suffix (file old-suffix new-suffix)
  "If FILE ends with OLD-SUFFIX, replace it with NEW-SUFFIX and return the
result.  Otherwise, return nil."
  (if (string-match (concat ".*/\\(\[^/\]*\\)" (regexp-quote old-suffix) "$")
		    file)
      (concat obj-file-prefix
	      (substring file (match-beginning 1) (match-end 1))
	      new-suffix)
    nil))

(defun obj-from-src (file)
  "Replace filename ending with .c with .o or ending with .uil with .uid."
  (let (o-file)
    (or (setq o-file (replace-file-suffix file ".c" ".o"))
	(setq o-file (replace-file-suffix file ".cc" ".o"))
	(setq o-file (replace-file-suffix file ".cpp" ".o"))
	(setq o-file (replace-file-suffix file ".uil" ".uid"))
	(not (setq o-file nil)))
    o-file))  

(defvar make-command "make" "*Command to use for make functions")

(defun make-this-file ()
  "Run make for the object file corresponding to this source file."
  (interactive)
  (let (o-file)
    (if (setq o-file (obj-from-src buffer-file-name))
	(compile (concat make-command " " o-file))
      (error "Can't determine object file name from buffer file name."))))

(defun current-sexp ()
  "Return as a string the sexp currently surrounding the cursor"
  (let (s-begin s-end)
    (save-excursion
      (forward-sexp -1)
      (setq s-begin (point))
      (forward-sexp 1)
      (setq s-end (point)))
    (buffer-substring s-begin s-end)))

(defun dep-grep ()
  "Run grep for the current SEXP through the dependencies of the object file
for the current source file.
Prepends the value of obj-file-prefix to the filename to find the object
file.  This is useful if the object file is in a different directory."
  (interactive)
  (let (o-file sexp answer)
    (if (setq o-file (obj-from-src buffer-file-name))
	(progn
	  (setq sexp (current-sexp))
	  (setq answer (read-string (concat "Grep for (default: " sexp "): ")))
	  (if (not (equal answer ""))
	      (setq sexp answer))
	  (grep (format "grep -n -w %s `deps_of %s`" sexp o-file)))
      (error "Can't determine object file name from buffer file name."))))

;;
;; This function is probably not well-behaved.  It makes assumptions
;; about window layout that are not generally correct.  What I'm trying
;; to acheive here is to have the point at the bottom of the compilation
;; buffer scrolls continuously.  Doing this with set-buffer doesn't work.
;;
(defun make (prefix)
  "Run make -k via compile.  With prefix, omit -k."
  (interactive "P")
  (if (null prefix)
      (compile (concat make-command " -k"))
    (compile make-command)
    )    
  (let ((buf (current-buffer)))
    (other-window 1)
    (switch-to-buffer (get-buffer "*compilation*"))
    (goto-char (point-max))
    (other-window -1)))

(defun dmake ()
  "Run make -k DFLAGS=\"-g -DDEBUG\" via compile"
  (interactive)
  (compile (concat make-command " -k DFLAGS=\"-g -DDEBUG\"")))

(defun clean-region () 
  "Removes ^H, ^G, and ^M from the current region."
  (interactive)
  (save-excursion
    (narrow-to-region (point) (mark))
    (goto-char (point-min))
    (replace-string "\C-m" "")
    (goto-char (point-min))
    (replace-string "\C-g" "")
    (goto-char (point-min))
    (while (search-forward "\C-h" (point-max) 1)
      (backward-delete-char 2))
    (widen))
  )

(defun prepend-lines-in-region ()
  (interactive)
  (let (string)
    (setq string (read-string "Prepend lines: "))
    (save-excursion
      (save-restriction
	(if (> (point) (mark)) (exchange-point-and-mark))
	(narrow-to-region (point) (mark))
	(goto-char (point-min))
	(while (not (eobp))
	  (beginning-of-line)
	  (insert string)
	  (next-line 1)
	)
      )
    )
  )
)

(defun countto (arg)
  "Count to argument printing each number followed by a newline"
  (interactive "p")
  (let (i)
    (setq i 1)
    (while (<= i arg)
      (insert (int-to-string i) "\n")
      (setq i (1+ i)))))

(defun query-delete-cc()
  "Ask if CC: line in mail buffer should be kept; if not, remove it."
  (if (yes-or-no-p "Remove CC: line ")
      (save-excursion
	(let (beginning-of-cc)
	  (if (re-search-backward "^CC:" nil t)
	      (progn
		(setq beginning-of-cc (point))
		(forward-char 1)
		(re-search-forward "^[^ \t]" nil t)
		(backward-char 1)
		(delete-region beginning-of-cc (point))))))))

(defun di ()
  "backs up .meetings and starts discuss"
  (interactive)
  (copy-file (expand-file-name "~/.meetings")
	     (expand-file-name "~/.meetings1") t)
  (if (not (file-exists-p "/usr/sipb/lib/elisp"))
      (call-process "attach" nil nil nil "sipb"))
  (discuss nil))

(defun q-space (n)
  "If buffer is readonly, does a scroll-up; otherwise, inserts a space."
  (interactive "P")
  (if buffer-read-only
      (scroll-up n)
    (progn
      (if (null n)
	  (setq n 1)
	(if (listp n)
	    (setq n (car n))))
      (self-insert-command n))))


(defun q-recenter()
  (interactive)
  (recenter 1))

(defun q-pop-mark()
  (interactive)
  (pop-mark)
  (exchange-point-and-mark))

(defun insert-space ()
  (interactive)
  (insert-string " ")
  (backward-char))

(defun fill-indented ()
  "Fill a region indented by non-alphanumeric characters.  The kinds of
regions that can be filled this way are those that have the same
characters indenting each line.  For example,
   *
   * This function would work
   * on this
   * block
   *

   % But it would
  * not work
   %    On this block.\n"
  (interactive)
  (let (start comment-str comment-len ofc)
    (save-restriction
      (save-excursion
	(narrow-to-region (point) (mark))
	(untabify (point-min) (point-max))
	(goto-char (point-min))
	(setq start (point))
	(skip-chars-forward "^a-zA-Z0-9")
	(setq comment-str (buffer-substring start (point)))
	(setq comment-len (- (point) start))
	(goto-char (point-min))
	(replace-string comment-str "" '())
	(setq ofc fill-column)
	(set-fill-column (- ofc comment-len))
	(fill-region (point-min) (point-max))
	(set-fill-column ofc)
	(goto-char (point-min))
	(save-restriction
	  (save-excursion
	    (narrow-to-region (point-min) (- (point-max) 1))
	    (replace-regexp "^" comment-str '())))
	(tabify (point-min) (point-max))))))

(defun make-maketarget ()
  (interactive)
  (let ((save-point nil) (target-name ""))
    (save-excursion
      (setq save-point (point))
      (beginning-of-line 1)
      (setq target-name (buffer-substring (point) save-point)))
    (insert ": ")
    (insert target-name)
    (insert ".o
	$(CC) -o ")
    (insert target-name)
    (insert " ")
    (insert target-name)
    (insert ".o\n")
    )
  )

(defun break-link ()
  "Follow the symbolic link corresponding to the current buffer and
revert buffer"
  ;; Uses ~/scripts/follow
  (interactive)
  (call-process "follow" nil nil nil buffer-file-name)
  (revert-buffer t t))

(defun follow-link ()
  "If the current buffer is a symbolic link, replace it with the file that
it is a link to."
  (interactive)
  (let ((real-file nil))
    (while (setq real-file (file-symlink-p buffer-file-name))
      (find-alternate-file real-file))
    (message "Actual file: %s" buffer-file-name)))


(defun decode-buffer (dir)
  "Uudecode the current buffer (or current restriction) in a given directory."
  (interactive "DEnter directory: ")
  (call-process-region (point-min) (point-max) "sh" nil nil nil
		       "-c" (concat "cd " (expand-file-name dir)
				    "; decode_multi"
			    )
  )
)

(defun find-uncompress-cmd ()
  (if (or (file-exists-p "/usr/local/bin/gzip")
	  (file-exists-p "/usr/bin/gzip")
	  (file-exists-p "/bin/gzip"))
      "gunzip"
    "uncompress"))

(defun compressed-mode ()
  "Replace contents of buffer with result of uncompressing contents of buffer"
  (interactive)
  (let (uncompress-cmd)
    (auto-save-mode 0)
    (setq buffer-read-only nil)
    (message "Uncompressing...")
    (setq uncompress-cmd (find-uncompress-cmd))
    (shell-command-on-region (point-min) (point-max) uncompress-cmd t)
    (message "Uncompressing...done")
    (let ((old-file-name buffer-file-name))
      (if (and (not (null buffer-file-name))
	       (string-match "\\.[^.]*$" buffer-file-name))
	  (set-visited-file-name
	   (substring buffer-file-name 0 (match-beginning 0))))
      (normal-mode)
      (set-visited-file-name old-file-name))
    (auto-save-mode 0)
    (set-buffer-modified-p nil)
    (setq buffer-read-only t)
    (goto-char (point-min))))

(defun underline-with-char (char)
  "Underline the current line with a given character.  
If run with a prefix arg, the user is prompted for the character.
Otherwise, a default of = is used.  In this case, underline means to
put a line below the current line containing the same number of
characters rather than to overstrike as underline-region does."
  (interactive "P")
  (let (start-pt end-pt)
    (if (not char)
	(setq char ?=)
      (message "Enter character: ")
      (setq char (read-char)))
    (beginning-of-line)
    (setq start-pt (point))
    (save-excursion
      (end-of-line)
      (if (eobp)
	  (insert "\n")))
    (forward-line 1)
    (let ((regexp (concat "\\s-*" (char-to-string char) "+" "\\s-*$")))
      (if (looking-at regexp)
	  (delete-region (point) (save-excursion (forward-line 1) (point)))
      )
    )
    (setq end-pt (point))
    (insert (buffer-substring start-pt end-pt))
    (setq start-pt end-pt)
    (setq end-pt (point))
    (save-restriction
      (narrow-to-region start-pt end-pt)
      (untabify (point-min) (point-max))
      (goto-char (point-min))
      (skip-chars-forward " ")
      (while (re-search-forward "." nil t)
	(replace-match  (char-to-string char) nil nil)
      )
    )
  )
)

      
;;
;; Support for checking mail from a second mail file into
;; a second rmail file
;;

(defvar sys-mbox (expand-file-name "~/work/sys-mail/mbox")
  "*System mail input file")
(defvar sys-rmail-file (expand-file-name "~/rmail/sys-inbox")
  "*System rmail file")

(defun sys-rmail()
  (interactive)
  (require 'rmail)
  (rmail sys-rmail-file)
  (rmail-get-new-mail sys-mbox)
  (call-process "cp" nil nil nil "/dev/null" sys-mbox)
  (call-process "chmod" nil nil nil "622" sys-mbox))
    
;;(defun auto-compile ()
;;  (let ((saved-hooks write-file-hooks))
;;    (unwind-protect
;;	(progn
;;	  (setq write-file-hooks nil)
;;	  (basic-save-buffer)
;;	  (byte-compile-file buffer-file-name)
;;	  (message "Saved and byte compiled.")
;;	  (normal-mode)
;;	  t)
;;      (setq write-file-hooks saved-hooks))))

(defun imake-continue-lines (start-pt end-pt)
  "Put continuation characters (@@\\) at the end of each line in the
region."
  (interactive "r")
  (save-excursion
    (save-restriction
      (narrow-to-region start-pt (1- end-pt))
      (goto-char (point-min))
      (let (saved-point)
	(while (progn
		 (beginning-of-line)
		 (setq saved-point (point))
		 (if (looking-at ".*@@\\\\$")
		     (save-excursion
		       (replace-regexp "@@\\\\$" "")))
		 (end-of-line)
		 (indent-to-column 74)
		 (insert "@@\\")
		 (forward-line 1)
		 (beginning-of-line)
		 (not (= (point) saved-point))))
	))))

(defun kill-to-eob ()
  "Kill from point to end of buffer"
  (interactive)
  (kill-region (point) (point-max)))

(defun symlink-check ()
  "Check to see whether this file is a symbolic link and take appropriate
action if so.  This is a find-file-hook."
  (if (file-symlink-p buffer-file-name)
      (progn
	(message (concat "WARNING: File is a symbolic link; "
			 "editing read-only."))
	(if (not buffer-read-only)
	    (toggle-read-only)))))

(defun big-font ()
  (interactive)
  (set-default-font "-misc-fixed-medium-r-normal--15-*"))

(defun normal-font ()
  (interactive)
  (set-default-font "-misc-fixed-medium-r-normal--13-*"))

(defun find-file-at-point ()
  "Find the file whose name is surrounded by the current point position
and show it an another window."
  (interactive)
  (find-file-other-window
   (buffer-substring 
    (save-excursion (skip-chars-backward "^ \t\n") (point))
    (save-excursion (skip-chars-forward "^ \t\n") (point)))))

(defun disable-mail ()
  "Disable mail, rmail, gnus, and discuss commands to prevent accidental use."
  (interactive)
  (fmakunbound 'mail)
  (fmakunbound 'rmail)
  (fmakunbound 'gnus)
  (fmakunbound 'gnus-post-news)
  (fmakunbound 'discuss)
  (fmakunbound 'sys-rmail)
  )

(defun command-output (cmd &rest args)
  "Run command and return its output as a string"
  (let ((buf (get-buffer-create (concat (make-temp-name "*") "*")))
	result)
    (save-excursion
      (set-buffer buf)
      (erase-buffer)
      (eval (append '(call-process cmd nil t nil) args))
      (goto-char (point-max))
      (delete-backward-char 1)
      (setq result (buffer-string))
      (kill-buffer buf)
      result)))

(defun reset-tags-tables ()
  "Reset tags-table variables to cancel effect of previous visit-tags-table."
  (interactive)
  (setq tags-file-name nil
	tags-included-tables nil
	tags-location-stack nil
	tags-table-files nil
	tags-table-list nil
	tags-table-list-pointer nil
	tags-table-list-started-at nil
	tags-table-parent-pointer-list nil
	tags-table-set-list nil)
  (if (fboundp 'reset-qtag)
      (reset-qtag))
  )

(defun revert-some-buffers (&optional arg)
  "Revert some file-visiting buffers.  Asks user about each one.
First, all unmodified buffers are asked about.  Then all modified buffers.
Optional argument (the prefix) > 1 means revert all unmodified buffers
with no questions but ask about modified buffers.  Negative means don't
ask any questions."
  (interactive "p")
  (let ((help '("buffer" "buffers" "revert"))
	(action-alist
	 (list (list ?\C-r (lambda (buf)
			     (view-buffer buf)
			     (let ((view-exit-action
				    '(lambda (ignore)
				       (exit-recursive-edit))))
			       (recursive-edit))
			     ;; Return nil to ask about BUF again.
			     nil)
		     "display the current buffer")))
	(action (function
		 (lambda (buffer)
		   (set-buffer buffer)
		   (revert-buffer t t)))))
    (save-window-excursion
      (let ((unmodified-files-done
	     (map-y-or-n-p
	      (function
	       (lambda (buffer)
		 (and (not (buffer-modified-p buffer))
		      (buffer-file-name buffer)
		      (file-exists-p (buffer-file-name buffer))
		      (if (and arg (or (> arg 1) (< arg 0)))
			  t
			(format "Revert buffer %s? "
				(buffer-file-name buffer))))))
	      action
	      (buffer-list)
	      help
	      action-alist))
	    (modified-files-done
	     (map-y-or-n-p
	      (function
	       (lambda (buffer)
		 (and (buffer-modified-p buffer)
		      (buffer-file-name buffer)
		      (file-exists-p (buffer-file-name buffer))
		      (if (and arg (< arg 0))
			  t
			(format "Revert modified buffer %s? "
				(buffer-file-name buffer))))))
	      action
	      (buffer-list)
	      help
	      action-alist)))
	(or (> unmodified-files-done 0)
	    (> modified-files-done 0)
	    (message "(No buffers need reverting)"))))))


(defun dots ()
  "Draw . . . . . from end of text before point to three spaces before point"
  (interactive)
  ;; Note: need to set end twice.  The first value is used to calculate
  ;; start; the second may differ because of the untabify.
  (let* ((end (point))
	 (start (save-excursion
		  (skip-chars-backward " \t")
		  (untabify (point) end)
		  (+ 1 (point))))
	 (end (- (point) 3)))
    (save-excursion
      (goto-char end)
      (while (>= (point) start)
	(delete-char 1)
	(insert ".")
	(backward-char 3)))))


(defun show-full-buffer ()
  "Show all text in this buffer (obeying narrowing) by removing 'invisible prop"
  (interactive)
  (let ((was-readonly buffer-read-only)
	(was-modified (buffer-modified-p))
	)
    (setq buffer-read-only nil)
    (put-text-property (point-min) (point-max) 'invisible nil)
    (if (not was-modified)
	(set-buffer-modified-p nil)
      )
    (if was-readonly
	(setq buffer-read-only t)
      )
    )
  )


(defun hide-c++-comments ()
  "Hide C++ comments that start at the beginning of the line."
  (interactive)
  (hide-comments "//"))

(defun hide-shell-comments ()
  "Hide shell comments that start at the beginning of the line."
  (interactive)
  (hide-comments "#"))

(defun hide-comments (cmt)
  "Hide comments that start at the beginning of the line.
If called interactively, prompt for a comment character."
  (interactive "sEnter comment character(s): ")
  (if (and (buffer-modified-p)
	   (buffer-file-name)
	   (or (not (y-or-n-p "Save file? "))
	       (save-buffer)
	       )
	   )
      (error "Can't hide comments in unsaved buffer.")
    )

  (let ((was-readonly buffer-read-only)
	(was-modified (buffer-modified-p))
	(last-line-hidden nil)
	)
    (setq buffer-read-only nil)
    (save-excursion
      (goto-char (point-min))
      (while (not (= (point) (point-max)))
	(skip-chars-forward " \t")
	(if (or (looking-at cmt)
		(and last-line-hidden (eolp))
		)
	    (progn
	      (put-text-property
	       (save-excursion (beginning-of-line) (point))
	       (save-excursion (end-of-line) (1+ (point)))
	       'invisible t
	       )
	      (setq last-line-hidden t)
	      )
	  (setq last-line-hidden nil)
	  )
	(forward-line 1)
	)
      )

    (if (not was-modified)
	(set-buffer-modified-p nil)
      )
    (if was-readonly
	(setq buffer-read-only t)
      )
    )
  )

(defun make-file-executable ()
  "Make file associated with this buffer executable."
  (interactive)
  (shell-command (concat "chmod +x " (buffer-file-name)))
  )

(defun make-file-writable ()
  "Make file associated with this buffer executable."
  (interactive)
  (shell-command (concat "chmod u+w " (buffer-file-name)))
  )

(defvar alternative-mail-addr-alist
  '(("ql.org" . "E. Jay Berkenbilt <ejb@ql.org>")
    ("apexinc.com" . "E. Jay Berkenbilt <ejb@apexinc.com>")
    ("mit.edu" . "E. Jay Berkenbilt <qjb@mit.edu>")
    ("mit-alum" . "E. Jay Berkenbilt <qjb@alum.mit.edu>")
    ("pager" . "q@ql.org")
    )
  "*personal mail addresses for q-mail-alternative")

(defun q-mail-alternative (addr)
  "Insert From: alternative-mail-addr at top of mail message."
  (interactive (list (let ((completion-ignore-case t)
			   (prompt "Which email address? "))
		       (and alternative-mail-addr-alist
			    (completing-read prompt
					     alternative-mail-addr-alist
					     nil nil)
			    )
		       )
		     )
	       )
  (let ((full-addr (or (cdr (assoc addr alternative-mail-addr-alist))
		       addr
		       )
		   )
	)
    (save-excursion
      (goto-char (point-min))
      (insert (concat "From: " full-addr "\n"))
      )
    )
  )

(defun q-fix-from-address ()
  "Attempt to fix From address based on To address"
  ;; called from mail-setup-hook
  (save-excursion
    (goto-char (point-min))
    (if (re-search-forward "^to: .*@.*apexinc.com" nil t)
	(q-mail-alternative "apexinc.com"))
    )
  )

(defun q-query-from-address ()
  "If From: is not given explicitly, prompt for a from address"
  (save-excursion
    (goto-char (point-min))
    (if (not (and (re-search-forward "^from: " nil t)
		  (search-forward "--text follows this line--" nil t)
	     )
	)
	(call-interactively 'q-mail-alternative)
    )
  )
)  

(defun q-check-from-address ()
  "Offer to fix From address based on To address"
  ;; called from mail-send-hook
  (save-excursion
    (goto-char (point-min))
    (if (re-search-forward "^to: .*@.*apexinc.com" nil t)
	(and (not (string-match "apexinc\\.com" user-mail-address))
	     (not (save-excursion
		    (goto-char (point-min))
		    (re-search-forward "^from: .*@.*apexinc.com" nil t)
		    )
		  )
	     (y-or-n-p "Sending to apexinc.com.  Fix from address? ")
	     (q-mail-alternative "apexinc.com"))
      )
    )
  )

(defun q-perl-accessor (arg)
  "When called with point positioned on a field name, creates perl accessor.
With prefix argument, allows argument to modify the field."
  (interactive "p")
  (beginning-of-line)
  (let* ((start (point))
	 (end (save-excursion (end-of-line) (point)))
	 (var (buffer-substring start end))
	 save-point)
    (delete-region start end)
    (push-mark)
    (insert "sub ")
    (setq save-point (point))
    (insert var "\n"
	    "{\n"
	    "    my $rep = shift;\n")
    (if (> arg 1)
	(insert "    $rep->{$package}{$f_" var "} = $_[0] if @_;\n"))
    (insert "    $rep->{$package}{$f_" var "};\n"
	    "}")
    (forward-line 1)
    (if (not (looking-at "^\\s-*$"))
	(insert "\n")
      (forward-line 1))
    (push-mark)
    (goto-char save-point)
    )
  )

(defun require-local-newline ()
  "Require newline in this buffer."
  (interactive)
  (make-local-variable 'require-final-newline)
  (setq require-final-newline t)
)

(defun q-journal-insert-date ()
  "Insert the date a form suitable for Q's journal entries."
  (interactive)
  (let ((str (format-time-string "%A, %B %d, %Y  %I:%M %p %Z" (current-time)))
	(result nil)
       )
    (string-match (concat "^\\([A-Za-z]+, [A-Za-z]+ \\)"
			  "0?\\([1-9][0-9]?, .*\\)"
			  "\\([AP]\\)M\\(.*\\)$")
		  str
    )
    (setq result (concat (match-string 1 str) (match-string 2 str)
			 (downcase (match-string 3 str)) ".m."
			 (match-string 4 str)
		 )
    )
    (insert result "\n\n")
  )
)

(defvar fscb-left   6 "left margin of TEXT")
(defvar fscb-right 70 "right margin of LINE including comment marker")
(defun fix-sgml-comment-block ()
  "Fix comment block style in SGML mode.
This can be run on any block of text, which is formatted as a paragraph and 
set with sgml comment characters around it."
  (interactive)
  (save-excursion
    (save-restriction
      (let ((after-change-function nil))
	(narrow-to-region (point) (mark))
	(goto-char (point-min))
	(while (search-forward "<!--" nil t)
	  (replace-match "" nil t)
	)
	(goto-char (point-min))
	(while (search-forward "-->" nil t)
	  (replace-match "" nil t)
	)
	(goto-char (point-min))
	(while (search-forward "--" nil t)
	  (replace-match "" nil t)
	)
	(goto-char (point-min))
	(while (re-search-forward "^\\s-+" nil t)
	  (replace-match "" nil t)
	)
	(goto-char (point-min))
	(let ((fill-column (- fscb-right fscb-left 5)))
	  (fill-paragraph nil)
	)
	(goto-char (point-min))
	(while (not (eobp))
	  (insert "<!--")
	  (indent-to-column fscb-left)
	  (end-of-line 1)
	  (indent-to-column (- fscb-right 3))
	  (insert "-->")
	  (beginning-of-line 2)
	)
      )
    )
  )
)

(defun q-set-frame-name (name)
  (interactive "sFrame name: ")
  (modify-frame-parameters (selected-frame)
			   (list (cons 'name name)))
  ;; This call to (message) makes the modify-frame-parameters take
  ;; effect immediately.
  (message nil)
)

(defun fix-frame-parameters ()
  "Fix frame parameters for how I like my frames displayed"
  (if (and (boundp 'window-system) window-system)
      (progn
	;; Fix frame name
	(if (null (cdr (assq 'name default-frame-alist)))
	    (let ((name (concat (or (getenv "WHO") (user-login-name))
				"@" (system-name))
		  )
		 )
	      (set-frame-name name)
	      (setq default-frame-alist
		    (append default-frame-alist (list (cons 'name name)
						)
		    )
	      )
	    )
	)
	
	(let ((o-height (frame-height))
	      top height
	     )
	  (if (> o-height 32)
	      (setq height (string-to-int (format "%d" (* .8 o-height))))
	    (setq height o-height)
	  )
	  (setq top (+ (* 5 (- o-height height)) 1))
	  (setq default-frame-alist
		(append (list (cons 'top top)
			      (cons 'height height)
			      (cons 'left 1)
			)
			default-frame-alist
		)
	  )
	  (if (boundp 'special-display-frame-alist)
	      (setq special-display-frame-alist
		    (append (list (cons 'top top)
				  (cons 'left 1)
			    )
			    special-display-frame-alist
		    )
	      )
	  )
	)
      )
  )
)

(defun q-new-frame (arg)
  (interactive "P")
  (let (name)
    (if (null arg)
	(setq name nil)
      (setq name (read-string "Enter name: ")))
    (new-frame (if name (list (cons 'name name)) nil)))
)

(defun inhibit-desktop-save ()
  "Prevent desktop-save from being called on exit."
  (interactive)
  (fset 'desktop-kill (lambda() nil))
)

(defun work-around-vc-brain-damage ()
  "Starting in 19.29, vc started goofing around with buffer protections.
Undo this."
  (let ((before-vc nil)
	(after-vc find-file-hooks)
	(cur-hook nil)
	(found nil)
	(vc-hook 'vc-find-file-hook)
       )
    (while (and (not found) after-vc)
      (setq cur-hook (car after-vc))
      (setq after-vc (cdr after-vc))
      (if (eq cur-hook vc-hook)
	  (setq found t)
	(setq before-vc (append before-vc (list cur-hook)))
      )
    )
    (if found
	(setq find-file-hooks
	      (append before-vc
		      (list 'q-save-buffer-protections
			    vc-hook
			    'q-restore-buffer-protections
		      )
		      after-vc
	      )
	)
    )
  )
)

(defun clean-man ()
  "Remove nroff junk from manual page output"
  (interactive)
  (require 'man)
  (if (fboundp 'Man-fontify-manpage)
      (Man-fontify-manpage)
    (Man-set-fonts)
  )
)

(defvar q-bufprot-obarray [0 0 0 0 0] "Obarray for q-*-buffer-protections")

(defun q-save-buffer-protections ()
  "Save current buffer protections in property q-saved-buffer-protections"
  (put (intern buffer-file-name q-bufprot-obarray)
       'q-saved-buffer-protections buffer-read-only)
)

(defun q-restore-buffer-protections ()
  "Restore buffer protections from property q-saved-buffer-protections"
  (setq buffer-read-only (get (intern buffer-file-name q-bufprot-obarray)
			      'q-saved-buffer-protections))
)

(defun mimic-key (s)
  "Act like the key passed in as an argument was typed by looking the key
up and running its binding, or, if bound to self-insert-command, inserting
the string."
  (let ((binding (key-binding s t)))
    (if (eq binding 'self-insert-command)
	(insert s)
      (call-interactively binding))))

(defun mimic-del ()
  "Mimic the delete key being pressed"
  (interactive)
  (mimic-key "\C-?")
)

(defun mimic-tab ()
  "Mimic the tab key being pressed"
  (interactive)
  (mimic-key "\t")
)

(defun info-fix-face-fonts ()
  (if (fboundp 'make-face)
      (progn
	(copy-face 'bold-italic 'info-xref)
	(copy-face 'bold 'info-node)
      )
  )
)

(defun q-find-file-literally ()
  "Wrapper for find-file-literally"
  (interactive)
  (let ((default-major-mode 'fundamental-mode))
    (call-interactively 'find-file-literally)
  )
)

;; Address list stuff
(defvar fix-addresslist-prog
  (expand-file-name "~/Q/personal/address/fix_addresslist")
)

(defun fix-zipcode ()
  (interactive)
  (let (current-point start end before-filename after-filename)
    (setq current-point (point))
    (save-excursion
      (search-backward "\n\n")
      (forward-line 2)
      (setq start (point))
      (search-forward "\n\n")
      (setq end (point))
      (setq before-filename (make-temp-name (concat "/tmp/addr.")))
      (write-region start end before-filename)
      (setq after-filename (make-temp-name (concat "/tmp/addr.")))
      (call-process fix-addresslist-prog nil nil nil
		    before-filename after-filename
      )
      (goto-char start)
      (delete-region start end)
      (insert-file-contents after-filename)
      (delete-file before-filename)
      (delete-file after-filename)
    )
    (goto-char current-point)
  )
)

(defvar clean-mime-prog "clean_mime")

(defun clean-mime (start end)
  (interactive "r")
  
  (let ((was-readonly buffer-read-only)
	(in-rmail (eq major-mode "rmail-mode"))
       )
    (setq buffer-read-only nil)
    (if in-rmail
	(rmail-edit-current-buffer)
    )
    (call-process-region start end clean-mime-prog t t nil)
    (if in-rmail
	(rmail-cease-edit)
    )
    (setq buffer-read-only was-readonly)
  )
)

(defun q-do-without-modifying-buffer (f)
  "Perform some operation without modifying buffer"
  (save-excursion
    (let ((modified (buffer-modified-p))
	  (buffer-undo-list t)
	  (inhibit-read-only t)
	 )
      (let (before-change-functions after-change-functions)
	(funcall f)
	(and (not modified) (buffer-modified-p) (set-buffer-modified-p nil))
      )
    )
  )
)

(defun remove-ms-tnef ()
  "Remove a mime enclosure of type application/ms-tnef
These enclosures are created automatically by some versions of MS Exchange"
  (interactive)
  (let (eoh
	boundary
       )
    (save-excursion
      (goto-char (point-min))
      (if (re-search-forward "\\(\n\\)\\(\n\\)" nil t)
	  (progn
	    (setq eoh (match-beginning 2))
	    (goto-char (point-min))
	    (if (re-search-forward
		 "boundary=\"\\(.*\\)\"$" eoh t)
		(setq boundary (match-string 1))
	    )
	  )
      )
      (if boundary
	  (progn
	    (goto-char eoh)
	    (if (re-search-forward
		 (concat "^--" (regexp-quote boundary) "\n"
			 "Content-Type: application/ms-tnef\n")
		 nil t)
		(let ((start (match-beginning 0)))
		  (goto-char (match-end 0))
		  (if (re-search-forward
		       (concat "^--" (regexp-quote boundary))
		       nil t
		      )
		      (let ((end (match-beginning 0))
			    (in-rmail (eq major-mode "rmail-mode"))
			    (buffer-was-read-only (and buffer-read-only 1))
			   )
			(toggle-read-only nil)
			(if in-rmail
			    (rmail-edit-current-buffer)
			)
			(delete-region start end)
			(if in-rmail
			    (rmail-cease-edit)
			)
			(toggle-read-only buffer-was-read-only)
		      )
		  )
		)
	    )
	  )
      )
    )
  )
)

;; grab-text-between and diff-test-output are for use with my perl
;; test driver stuff
(defun grab-text-between (start-anchor end-anchor)
  "return the string between the anchor text
moving the cursor to after end-anchor"
  (let (start end)
    (search-forward start-anchor)
    (setq start (match-end 0))
    (search-forward end-anchor)
    (setq end (match-beginning 0))
    (buffer-substring start end)
  )
)

;; grab-text-between and diff-test-output are for use with my perl
;; test driver stuff
(defun diff-test-output ()
  "ediff expected and actual output from test suite"
  (interactive)
  (let (str exp-buffer act-buffer)
    (setq str (grab-text-between
	       "--> BEGIN EXPECTED OUTPUT <--\n"
	       "--> END EXPECTED OUTPUT <--")
    )
    (save-excursion
      (setq exp-buffer (get-buffer-create "*expected output*"))
      (set-buffer exp-buffer)
      (delete-region (point-min) (point-max))
      (insert str)
      (set-buffer-modified-p nil)
    )

    (setq str (grab-text-between
	       "--> BEGIN ACTUAL OUTPUT <--\n"
	       "--> END ACTUAL OUTPUT <--")
    )
    (save-excursion
      (setq act-buffer (get-buffer-create "*actual output*"))
      (set-buffer act-buffer)
      (delete-region (point-min) (point-max))
      (insert str)
      (set-buffer-modified-p nil)
    )

    (ediff-buffers exp-buffer act-buffer)
  )
)