view release on metacpan or  search on metacpan

ide/bioperl-mode/site-lisp/bioperl-init.el  view on Meta::CPAN

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))