[Bioperl-guts-l] [16443] new feature: browse parent/base classes

Mark Allen Jensen maj at dev.open-bio.org
Sun Dec 6 17:20:09 EST 2009


Revision: 16443
Author:   maj
Date:     2009-12-06 17:20:08 -0500 (Sun, 06 Dec 2009)
Log Message:
-----------
new feature: browse parent/base classes

Modified Paths:
--------------
    bioperl-dev/trunk/ide/emacs/bioperl-mode/test/bioperl-mode-test.el
    bioperl-live/trunk/ide/bioperl-mode/site-lisp/bioperl-init.el
    bioperl-live/trunk/ide/bioperl-mode/site-lisp/bioperl-mode.el

Modified: bioperl-dev/trunk/ide/emacs/bioperl-mode/test/bioperl-mode-test.el
===================================================================
--- bioperl-dev/trunk/ide/emacs/bioperl-mode/test/bioperl-mode-test.el	2009-12-04 23:46:10 UTC (rev 16442)
+++ bioperl-dev/trunk/ide/emacs/bioperl-mode/test/bioperl-mode-test.el	2009-12-06 22:20:08 UTC (rev 16443)
@@ -46,6 +46,19 @@
   (test-assert-equal (bioperl-split-name "Bio::Se" nil) '("Bio" "*Se"))
   (test-assert-equal (bioperl-split-name "Bio::Se" t) '("*Bio::Se" nil))
 
+  ;; find parent classes
+  (with-temp-buffer
+    (insert-file-contents "test-path-1/Bio/SeqIO.pm")
+    (setq bioperl-test-var (bioperl-find-class-parents (current-buffer))))
+  (test-assert-equal bioperl-test-var
+		       '("Bio::Root::Root" "Bio::Root::IO" 
+			 "Bio::Factory::SequenceStreamI") )
+  (with-temp-buffer
+    (insert-file-contents "test-path-1/Bio/SeqIO/abi.pm")  
+    (setq bioperl-test-var  (bioperl-find-class-parents (current-buffer))))
+    (test-assert-equal bioperl-test-var
+		       '("Bio::SeqIO" "Bio::SeqIO::staden::read") )
+  
   )
 
 ;;

Modified: bioperl-live/trunk/ide/bioperl-mode/site-lisp/bioperl-init.el
===================================================================
--- bioperl-live/trunk/ide/bioperl-mode/site-lisp/bioperl-init.el	2009-12-04 23:46:10 UTC (rev 16442)
+++ bioperl-live/trunk/ide/bioperl-mode/site-lisp/bioperl-init.el	2009-12-06 22:20:08 UTC (rev 16443)
@@ -251,6 +251,8 @@
 		  (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 )
@@ -267,7 +269,7 @@
 		  (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 "g" 'goto-line)
 		  (define-key map "i" 'imenu)
 		  (define-key map "\C-m" 'bioperl-view-pod)
 		  (define-key map "\C-\M-m" 'bioperl-view-pod-method)))

Modified: bioperl-live/trunk/ide/bioperl-mode/site-lisp/bioperl-mode.el
===================================================================
--- bioperl-live/trunk/ide/bioperl-mode/site-lisp/bioperl-mode.el	2009-12-04 23:46:10 UTC (rev 16442)
+++ bioperl-live/trunk/ide/bioperl-mode/site-lisp/bioperl-mode.el	2009-12-06 22:20:08 UTC (rev 16443)
@@ -158,10 +158,17 @@
 Use `bioperl-add-module-names-to-cache' to, well, do it.")
 
 (defvar bioperl-source-file nil
-  "Contains the source file of pod being viewed. Buffer-local.")
+  "Contains the source file of pod being viewed. Buffer-local.
+Set in `bioperl-view-full-pod'")
 
 (make-variable-buffer-local 'bioperl-source-file)
 
+(defvar bioperl-source-file-path-component nil
+  "Contains the path index (from `bioperl-module-path') for the source file of pod being viewed. Buffer-local.
+Set in `bioperl-view-full-pod'")
+
+(make-variable-buffer-local 'bioperl-source-file-path-component)
+
 (defvar bioperl-this-is-xemacs (or (string-match "^XEmacs" (emacs-version)))
   "Flag indicating whether we're in XEmacs.")
        
@@ -288,8 +295,44 @@
 		    (signal 'quit t))) (car (last mod)))))
   (bioperl-view-pod-section module "APPENDIX" n))
 
+
+(defun bioperl-view-pod-parents (module)
+  "Browse the pod for BioPerl modules from which MODULE inherits.
+MODULE is in double-colon format. Most useful when called from a pod view."
+  (unless (and module (stringp module))
+    (error "String required at arg MODULE"))
+  (if (not module)
+      nil
+    (let* (
+	   (pth-comp (if (boundp 'bioperl-source-file-path-component)
+			 bioperl-source-file-path-component nil))
+	  (pmfile (bioperl-path-from-perl module pth-comp))
+	  (parents)
+	  (mod)
+	  )
+      (unless pmfile
+	(error "Module specified by MODULE not found in installation"))
+      (with-temp-buffer
+	(insert-file-contents pmfile)
+	(setq parents (bioperl-find-class-parents (current-buffer))))
+      (if (not parents)
+	  (error "Unable to identify module parents")
+	;; create a (degenerate) alist
+	(setq parents (mapcar 'list parents))
+	(setq mod (completing-read "[pod]: " parents nil t 
+				   (if (= (length parents) 1) 
+				       (elt parents 0)
+				     "Bio::")))
+	(if mod
+	    (bioperl-view-pod mod pth-comp)
+	  nil))
+      )))
+
+
 (defun bioperl-view-source ()
-  "Display the file in `bioperl-source-file' in view mode in a new buffer."
+  "Display the file in the variable `bioperl-source-file' in view mode in a new buffer.  
+When in bioperl-view-mode, `bioperl-source-file' will contain the
+path to the source of the module whose pod is being viewed."
   (interactive)
   (if (not (file-exists-p bioperl-source-file))
       nil
@@ -300,6 +343,20 @@
       (bioperl-source-mode)
       (pop-to-buffer (current-buffer)))))
 
+(defun bioperl-view-parents ()
+  "Browse pod of base classes for the file in `bioperl-source-file' by completion menu.  
+When in bioperl-view-mode, `bioperl-source-file' will contain the
+path to the source of the module whose pod is being viewed."
+  (interactive)
+  (if (not (file-exists-p bioperl-source-file))
+      nil
+    (let (
+	  (mod)
+	  )
+      (mapcar (lambda (x) (setq mod (if mod (concat mod "::" x) x)))
+	      (bioperl-perl-from-path bioperl-source-file))
+      (bioperl-view-pod-parents mod))))
+
 ;; "uninstall..."
 
 (defun bioperl-mode-unload-hook &optional local
@@ -346,6 +403,18 @@
 	(goto-char (point-min))
 	(bioperl-view-mode)
 	(set (make-local-variable 'bioperl-source-file) pmfile)
+	(set (make-local-variable 'bioperl-source-file-path-component) nil)
+	;; set the path component
+	(let (
+	      (i 0) (done 0) (pth-comp (parse-colon-path bioperl-module-path))
+	      )
+	  (while (and (= done 0) (elt pth-comp i))
+	    (if (string-match 
+		 (regexp-quote (elt pth-comp i)) bioperl-source-file)
+		(setq done 1)
+	      (setq i (1+ i))))
+	  (if (elt pth-comp i)
+	      (setq bioperl-source-file-path-component i)))
 	(pop-to-buffer pod-buf))
       )
     ;;return val
@@ -791,6 +860,69 @@
 ;; string converters and finders
 ;;
 
+(defun bioperl-find-class-parents (buf)
+  "Look in the current buffer for parent classes to the displayed module.
+Searches for 'use base' and @ISA statements in buffer
+BUF. Returns a list of BioPerl modules in double colon
+format. Will probably fail (not dismally) if multiple packages
+are present in a single module file."
+  ;; how? by searching for 
+  ;; use base STUFF
+  ;; @ISA = STUFF
+  ;; push @ISA, STUFF
+  (unless (or (bufferp buf) (stringp buf))
+    (error "Require buffer or buffer name at BUF"))
+  (let (
+	(retmods)
+	)
+    (save-excursion
+      (set-buffer buf)
+      (goto-char (point-min))
+      ;; search for 'use base'...
+      (let* (
+	     (beg (re-search-forward "use base " (point-max) t))
+	     (end (if beg (re-search-forward ";" (point-max) t) nil))
+	     (txt (if beg (buffer-substring-no-properties beg (1- end)) nil))
+	     (toks)
+	     )
+	(if (not txt)
+	    nil
+	  (setq txt (replace-regexp-in-string "\n" " " txt))
+	  (setq txt (replace-regexp-in-string "\\(?:qw[\[\(\{\|][ \f\t\n\r\v]?\\)" "" txt))
+	  (setq txt (replace-regexp-in-string "[](){}'\"]" "" txt))
+	  (setq toks (split-string txt "[ \f\t\n\r\v]+" t))
+	  (mapcar (lambda (x) (push x retmods)) toks) ))
+      ;; search for @ISA
+      ;; ISA set needs to search over multi lines
+      ;; look at Bio::
+      (goto-char (point-min))
+      (let* (
+	     (beg (re-search-forward "@ISA\s?[,=]\s?" (point-max) t))
+	     (end (if beg (re-search-forward ";" (point-max) t) nil))
+	     (txt (if beg (buffer-substring-no-properties beg (1- end)) nil))
+	     (toks)
+	     (pass 1)
+	     )
+	(while (<= pass 2)
+	  (if (not txt)
+	      (setq pass (1+ pass))
+	    (setq txt (replace-regexp-in-string "\n" " " txt))
+	    (setq txt (replace-regexp-in-string "\\(?:qw[\[\(\{\|][ \f\t\n\r\v]?\\)" "" txt))
+	    (setq txt (replace-regexp-in-string "[](){}'\"]" "" txt))
+	    (setq toks (split-string txt "[ \f\t\n\r\v]+" t))
+	    (mapcar (lambda (x) (push x retmods)) toks) 
+	    (setq pass (1+ pass)))
+	  (setq beg (re-search-forward "@ISA\s?[,=]\s?" (point-max) t))
+	  (setq end (if beg (re-search-forward ";" (point-max) t) nil))
+	  (setq txt (if beg (buffer-substring-no-properties beg (1- end)) nil))
+	  )))
+      ;; filter for fully-qualified Bio:: modules...
+      (setq retmods 
+	    (delete nil (mapcar 
+			 (lambda (x) (if (string-match "^Bio::" x) x nil)) 
+		       retmods)))
+    (nreverse retmods) ))
+
 (defun bioperl-module-at-point ()
   "Look for something like a module identifier at point, and return it."
   (interactive)



More information about the Bioperl-guts-l mailing list