;; $Id$
;;
;; Init functions for Bioperl minor mode
;;
;; Author: Mark A. Jensen
;; Email : maj -at- fortinbras -dot- us
;;
;; Part of The Documentation Project
;; http://www.bioperl.org/wiki/The_Documentation_Project
;;
;;
;; Copyright (C) 2009 Mark A. Jensen
;; 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 of
;; the License, 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, write to the Free
;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301 USA
(defconst bioperl-init-revision "$Id$"
"The revision string of bioperl-init.el")
;;
;; menu bar keymaps
;;
(defvar menu-bar-bioperl-doc-menu
(let (
(map (make-sparse-keymap "BioPerl Docs"))
)
(define-key map [bp-pod-apx]
'(menu-item "View appendix" bioperl-view-pod-appendix
:help "View pod APPENDIX of a module (where most methods are described)"
:keys "\\[bioperl-view-pod-appendix]"))
(define-key map [bp-pod-dsc]
'(menu-item "View description" bioperl-view-pod-description
:help "View pod DESCRIPTION of a module"
:keys "\\[bioperl-view-pod-description]"))
(define-key map [bp-pod-syn]
'(menu-item "View synopsis" bioperl-view-pod-synopsis
:help "View pod SYNOPSIS of a module"
:keys "\\[bioperl-view-pod-synopsis]"))
(define-key map [bp-pod]
'(menu-item "View pod" bioperl-view-pod
:help "Examine entire pod of a module"
:keys "\\[bioperl-view-pod]"))
(define-key map [bp-pod-mth]
'(menu-item "View method pod" bioperl-view-pod-method
:help "View pod (Title:, Usage:, etc) for a single method"
:keys "\\[bioperl-view-pod-method]"))
map)
"Menu-bar map for doc functions in bioperl-mode.")
(defvar menu-bar-bioperl-ins-menu
(let (
(map (make-sparse-keymap "BioPerl Ins"))
)
(define-key map [bp-ins-arr]
'(menu-item "Insert container template" bioperl-insert-array-accessor
:help "Insert template functions for an object array"
:keys "\\[bioperl-insert-array-accessor]"))
(define-key map [bp-ins-obj]
'(menu-item "Insert class/object template" bioperl-insert-class
:help "Insert full object template plus std pod"
:keys "\\[bioperl-insert-class]"))
(define-key map [bp-ins-mthpod]
'(menu-item "Insert method pod template" bioperl-insert-method-pod
:help "Insert Bioperl standard method pod template"
:keys "\\[bioperl-insert-method-pod]"))
(define-key map [bp-ins-genpod]
'(menu-item "Insert generic class pod template" bioperl-insert-generic-class
:help "Insert package declaration plus std pod"
:keys "\\[bioperl-insert-generic-class]"))
(define-key map [bp-ins-acc]
'(menu-item "Insert accessor template" bioperl-insert-accessor
:help "Insert accessor (getter/setter) with std pod"
:keys "\\[bioperl-insert-accessor]"))
(define-key map [bp-ins-mod]
'(menu-item "Insert module identifier" bioperl-insert-module
:help "Insert module identifier, with completion"
:keys "\\[bioperl-insert-module]"))
map)
"Menu-bar map for insertion functions in bioperl-mode")
;;
;; keymap
;;
;; principles:
;; C-c accesses mode functions
;; meta key commands - documentation reading (pod display, etc.)
;; control key command - documentation writing (template insertions, etc.)
;;
(defvar bioperl-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "\C-c\M-p" 'bioperl-view-pod)
(define-key map "\C-c\M-d" 'bioperl-view-pod-description)
(define-key map "\C-c\M-s" 'bioperl-view-pod-synopsis)
(define-key map "\C-c\M-a" 'bioperl-view-pod-appendix)
(define-key map "\C-c\M-f" 'bioperl-view-pod-method)
(define-key map "\C-c\M-m" 'bioperl-view-pod-method)
(define-key map "\C-cm" 'bioperl-insert-module)
(define-key map "\C-c\C-a" 'bioperl-insert-accessor)
(define-key map "\C-c\C-v" 'bioperl-insert-accessor)
(define-key map "\C-c\C-A" 'bioperl-insert-array-accessor)
(define-key map "\C-c\C-b" 'bioperl-insert-class)
(define-key map "\C-c\C-M" 'bioperl-insert-class)
(define-key map "\C-c\C-k" 'bioperl-insert-generic-class)
(define-key map "\C-c\C-g" 'bioperl-insert-generic-class)
(define-key map "\C-c\C-p" 'bioperl-insert-method-pod)
(define-key map [menu-bar] nil)
(define-key map [menu-bar bp-ins]
(list 'menu-item "BP Templs" menu-bar-bioperl-ins-menu))
(define-key map [menu-bar bp-doc]
(list 'menu-item "BP Docs" menu-bar-bioperl-doc-menu))
map)
"Keymap for Bioperl minor mode")
;;
;; finders
;;
(defun bioperl-find-module-path (&optional symb val)
"Find path to Bioperl modules and set `bioperl-module-path'.
This path points to the directory containing Bio; same principle
as 'use lib'. SYMB and VAL are dummies allowing `defcustom' to do
initializaton."
(let (
(old-exec-path exec-path)
(pth) )
;; ask BPMODE_PATH first...
(setq pth (getenv "BPMODE_PATH"))
;; try the environment
(unless pth
(let (
( plib (concat (getenv "PERL5LIB") path-separator (getenv "PATH")))
( pths )
)
(if plib
(progn
(setq pths (split-string plib path-separator))
(while (and (not pth) pths)
;; unixize
;; (setq pth (replace-regexp-in-string "\\\\" "/" pth))
(setq pth (pop pths))
(setq pth (if (file-exists-p (concat pth "/" "Bio")) pth nil)))
))))
;; then ask Perl...
(unless pth
;; safe path
(if (or (not (boundp 'bioperl-mode-safe-flag))
bioperl-mode-safe-flag)
(setq exec-path bioperl-safe-PATH))
(setq pth
(with-temp-buffer
(call-process
"perl" nil t t
"-MConfig" "-e" "print $Config{sitelib}")
(goto-char (point-min))
(thing-at-point 'line)
))
;; reset exec-path
(setq exec-path old-exec-path)
;; file name port issue - unixize
(setq pth (replace-regexp-in-string "\\\\" "/" pth))
(setq pth (if (file-exists-p (concat pth "/" "Bio")) pth nil)))
;; fall back to pwd
(unless pth
(setq pth (nth 1 (split-string (pwd))))
;; unixize
(setq pth (replace-regexp-in-string "\\\\" "/" pth))
(setq pth (if (file-exists-p (concat pth "/" "Bio")) pth nil))
)
(if pth
(setq bioperl-module-path pth)
(message "Can't find Bio modules; defaulting to pwd -- try setting bioperl-module-path manually")
(setq bioperl-module-path "."))
pth))
(defun bioperl-set-safe-PATH (&optional symb val)
"Portably sets the safe-PATH, used when bioperl-mode calls the system.
SYMB and VAL are dummies allowing defcustom to do
initialization."
(cond
( (string-match "windows\\|mingw\\|nt" system-configuration)
(setq bioperl-safe-PATH '("c:/Perl/bin" "c:/Windows/system32")) )
( (string-match "unix\\|linux" system-configuration)
(setq bioperl-safe-PATH '("/bin" "/usr/bin" "/usr/local/bin")) )
( (string-match "cygwin" system-configuration)
(setq bioperl-safe-PATH '("/bin" "/usr/local/bin"
"/cygdrive/c/Windows/system32") ) )
( t
(setq bioperl-safe-PATH '()))))
(defvar bioperl-enabled-buffer-flag nil
"Buffer-local flag for enabling/disabling the bioperl-mode toolbar icon.")
(make-local-variable 'bioperl-enabled-buffer-flag)
;;
;; minor mode definition functions
;;
(define-minor-mode bioperl-mode
"Toggles Bioperl minor mode.
Bioperl mode provides Bioperl-flavored template insertion and
convenient access to POD documentation. More documentation to
come."
:init-value nil
:lighter "[bio]"
:keymap bioperl-mode-map
:group 'bioperl
;; version check
(if (string-match "\\(2[0-9]\\)\.[0-9]+\\(?:\.[0-9]+\\)?" (emacs-version))
(if (or (string-match "^XEmacs" (emacs-version))
(>= (string-to-number (match-string 1 (emacs-version))) 22))
t
(error "Must upgrade to XEmacs 22 to use bioperl-mode"))
(error "Must upgrade to Emacs 22 to use bioperl-mode"))
;; set up mode
(bioperl-skel-elements))
(define-minor-mode bioperl-view-mode
"A derived view mode for bioperl pod."
:init-value nil
:lighter "[bio]"
:keymap ( let* (
(vmap (cdr (assoc 'view-mode minor-mode-map-alist)))
(map (if vmap (copy-keymap vmap) (make-sparse-keymap) ))
)
(if map
(progn
(define-key map [menu-bar] nil)
(define-key map [menu-bar bp-doc] (list 'menu-item "BP Docs" menu-bar-bioperl-doc-menu))
(define-key map "q" 'View-kill-and-leave)
(define-key map "f" 'bioperl-view-source)
(define-key map "P" 'bioperl-view-parents)
(define-key map "B" 'bioperl-view-parents)
(define-key map "\C-m" 'bioperl-view-pod)
(define-key map "\C-\M-m" 'bioperl-view-pod-method)))
map )
;; and now, a total kludge.
(view-mode))
(define-minor-mode bioperl-source-mode
"A derived view mode for bioperl source code."
:init-value nil
:lighter "[bio]"
:keymap ( let ( (map (copy-keymap (cdr (assoc 'view-mode minor-mode-map-alist)))) )
(if map
(progn
(define-key map [menu-bar] nil)
(define-key map [menu-bar bp-doc] (list 'menu-item "BP Docs" menu-bar-bioperl-doc-menu))
(define-key map "q" 'View-kill-and-leave)
(define-key map "g" 'goto-line)
(define-key map "i" 'imenu)
(define-key map "P" 'bioperl-view-parents-this-buffer)
(define-key map "B" 'bioperl-view-parents-this-buffer)
(define-key map "\C-m" 'bioperl-view-pod)
(define-key map "\C-\M-m" 'bioperl-view-pod-method)))
map )
;; and now, a total kludge.
(view-mode))
(defface pod-section-face
'( (t (:weight bold :foreground "maroon3") ) )
"Highlight for pod section names.")
(defvar pod-section-face 'pod-section-face)
(defface pod-bioperl-identifier-face
'( (t (:foreground "blue3" :weight bold)))
"Highlight for bioperl identifiers")
(defvar pod-bioperl-identifier-face 'pod-bioperl-identifier-face)
(defface pod-method-pod-tag-face
'( (t (:foreground "blue4")) )
"Highlight for method pod tags (Title, Usage, etc.)")
(defvar pod-method-pod-tag-face 'pod-method-pod-tag-face)
(defface pod-blue-man-face
'( (t (:background "blue" :foreground "dark blue")))
"My world is blue.")
(defvar pod-blue-man-face 'pod-blue-man-face)
(defface pod-subsec-header-face
'( (t (:weight bold :slant italic :foreground "blue4")))
"Highlight pod subsection headers")
(defvar pod-subsec-header-face 'pod-subsec-header-face)
(defface pod-method-subsec-face
'( (t (:slant italic :foreground "maroon4")))
"Highlight for APPENDIX subsections")
(defvar pod-method-subsec-face 'pod-method-subsec-face)
(defface pod-method-name-face
'( (t (:weight bold) ) )
"Highlight pod method names")
(defvar pod-method-name-face 'pod-method-name-face)
(defface pod-key-value-arg-face
'( (t (:slant italic :foreground "green3")) )
"Highlight for key-value keys (-something)" )
(defvar pod-key-value-arg-face 'pod-key-value-arg-face)
(defface pod-deref-symb-face
'( (t (:weight bold :foreground "blue4")))
"Highlight '->' ")
(defvar pod-deref-symb-face 'pod-deref-symb-face)
(defface pod-assoc-symb-face
'( (t (:weight bold :foreground "green3")))
"Highlight '=>' ")
(defvar pod-assoc-symb-face 'pod-assoc-symb-face)
(defvar bioperl-pod-font-lock-keywords
'(
;; rudimentary perl syntax highlighting
("[%$][{]?\\([a-zA-Z0-9_]+\\)[}]?" 1 font-lock-variable-name-face)
("[^a-zA-Z0-9]@[{]?\\([a-zA-Z0-9_]+\\)[}]?" 1 font-lock-variable-name-face)
("\\>->\\<" . pod-deref-symb-face)
("\\(?:\\s \\|\\>\\)\\(=>\\)\\(?:\\s \\|\\<\\|[\'\"]\\)" 1 pod-assoc-symb-face)
("\\(?:\\W\\|\\s \\)\\(-[a-zA-Z0-9_]+\\)\\>" 1 pod-key-value-arg-face)
; ("'[^']+'" . 'font-lock-string-face)
(pod-find-syntactic-string 1 font-lock-string-face)
("\#\\s +.*" 0 font-lock-comment-face t)
;; headers
("^\\(?:[A-Z]+\\s \\)+" . pod-section-face )
("^\\s \\{2\\}\\([A-Z][a-z]+\\s \\)+" . (0 pod-subsec-header-face))
("^\\s \\{2\\}[a-z_][a-zA-Z0-9_()]+\\s " . pod-method-name-face)
("^\\s +[a-zA-Z]+\\s *:\\s " . pod-method-pod-tag-face)
("^[A-Z].*" . pod-method-subsec-face)
("Bio::\\(?:[a-zA-Z0-9_:]+\\)+" . pod-bioperl-identifier-face)
;; post-header syntax highlights
("\\(\\<[a-zA-Z0-9_]+\\>\\)()" 0 font-lock-function-name-face )
("\\(\\<[a-zA-Z0-9_]+\\>\\)[\(]" 1 font-lock-function-name-face )
("\\>->\\(\\<[a-zA-Z0-9_]+\\>\\)" 1 font-lock-function-name-face)
)
"Font lock keywords for highlighting Perl pod."
)
(defconst bioperl-pod-font-lock-defaults
'(bioperl-pod-font-lock-keywords t nil nil ))
(define-derived-mode pod-mode fundamental-mode "Pod Fundamental"
"Derived fundamental mode for highlighting BioPerl pod."
:group 'bioperl
:syntax-table nil
:abbrev-table nil
(set (make-local-variable 'font-lock-defaults)
bioperl-pod-font-lock-defaults))
(defun pod-find-syntactic-string (bound)
"String searcher for bioperl-mode font-lock."
;; try to infer from symbol context
(re-search-forward "\\(?:[$@%(),]\\|->\\|=>\\|print\\).*?\\(['][^']+[']\\|[\"][^\"]+[\"]\\)" bound t))
(defun bioperl-pod-synopsis-region (buffer)
"Return beginning & end of SYNOPSIS region (excluding the header)."
(unless (bufferp buffer)
(error "Buffer required at arg BUFFER"))
(save-excursion
(goto-char (point-min))
(let ( (beg) (end) )
(setq beg
(if (re-search-forward "^SYNOPSIS" (point-max) t)
(progn (forward-line 1) (if (bolp) (point) nil))
nil))
(setq end
(if (re-search-forward "^[A-Z]" (point-max) t)
(progn (beginning-of-line) (if (bolp) (point) nil))
nil))
(if (not (and beg end))
nil
`(,beg ,end)))))
(defun bioperl-perl-mode-infect ()
"Add this function to `perl-mode-hook' to associate bioperl-mode with perl-mode."
(unless (or (key-binding [tool-bar bpmode]) bioperl-this-is-xemacs (not (display-graphic-p)) )
(define-key (current-local-map) [tool-bar bpmode]
`(menu-item "bpmode" bioperl-mode
:image [,(find-image (list
'(:type xpm :file "bpmode-tool.xpm")))
,(find-image (list
'(:type xpm :file "bpmode-tool.xpm")))
,(find-image (list
'(:type xpm :file "bpmode-tool-dis.xpm")))
,(find-image (list
'(:type xpm :file "bpmode-tool-dis.xpm")))]
:enable bioperl-enabled-buffer-flag
)))
;; do something else in XEmacs...
(if bioperl-this-is-xemacs 1 0)
(setq bioperl-enabled-buffer-flag t)
(if bioperl-mode-active-on-perl-mode-flag (bioperl-mode) nil))
;; where are you, subr.el?
(unless (boundp 'booleanp)
(defun booleanp (x)
"Is it boolean? Let's find out."
(if (or (equal x t) (equal x nil))
t
nil)))
(provide 'bioperl-init)
;;; end bioperl-init.el