view release on metacpan or  search on metacpan

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

	    (insert-char ?  (- 8 (length cur-tag)))
	    (insert ": " cur-content))
	  (goto-char (point-min))
	  (bioperl-view-mode)
	  (set (make-local-variable 'bioperl-source-file) bioperl-cached-pmfile)
	  (pop-to-buffer pod-buf)))
      )))

;; 
;; completion tricks
;;

;; TODO: modularize...
(defun bioperl-completing-read (initial-input &optional get-method dir-first prompt-prefix no-retry)
  "Specialized completing read for bioperl-mode.
INITIAL-INPUT is a namespace/module name in double-colon format,
or nil. Returns a list: (namespace module path-string) if GET-METHOD is nil,
\(namespace module method path-string) if GET-METHOD is t. DIR-FIRST is
passed along to `bioperl-split-name'; controls what is returned
when a namespace name is also a module name (e.g., Bio::SeqIO).
If NO-RETRY is nil, the reader works hard to return a valid entity;
if t, the reader barfs out whatever was finally entered."
  (let ( (parsed (bioperl-split-name initial-input dir-first)) 
	 (nmspc) (mod) (mth) (pthn) (name-list)
	 (done nil))
    (if (not parsed)
	nil
      (setq nmspc (elt parsed 0))
      (setq mod (elt parsed 1)))
    (while (not done)
      ;; namespace completion
      (unless (and nmspc (not (string-match "^\*" nmspc)))
	(cond 
	 ( (not nmspc) nil )
	 ( (string-match "^\*" nmspc)
	   (setq initial-input (replace-regexp-in-string "^\*" "" nmspc))))
	(setq nmspc (completing-read 
		     (concat prompt-prefix "Namespace: ")
		     'bioperl-namespace-completion-function
		     nil (not no-retry) (or initial-input "Bio::")) )
	(if (or (string-equal nmspc "Bio") (not (string-equal nmspc "")))
	    t
	  ;; back up
	  (setq nmspc 
		(if (string-match ":" nmspc)
		    (car (split-string nmspc "::[^:]+$"))
		  nil))
	  (setq done nil)))
      ;; module completion
      (if (or (not nmspc)
		  (and mod (not (string-match "^\*" mod))))
	  (setq done t)
	(let (
	      ;; local vars here
	      )
	  (setq name-list (bioperl-module-names nmspc nil t))
	  (setq mod (completing-read 
		     (concat prompt-prefix nmspc " Module: ")
		     name-list nil (not no-retry)
		     (if mod (replace-regexp-in-string "^\*" "" mod) nil)))
	  ;; allow a backup into namespace completion
	  (if (or no-retry (not (string-equal mod "")))
	      (setq done t)
	    ;; retry setup
	    ;; try again, backing up
	    (setq done nil)
	    (let ( (splt (bioperl-split-name nmspc nil)) )
	      (if (elt splt 1)
		  (progn
		    (setq nmspc (elt splt 0))
		    ;; kludge : "pretend" mod is not found using the "*"
		    (setq mod (concat "*" (elt splt 1))))
		(setq nmspc (concat "*" nmspc))
		(setq mod nil)))
	    (setq initial-input nmspc))))
      ;; path completion
      (unless (or (not (and nmspc mod)) (not done) no-retry)
	(if (not name-list)
	  (setq name-list (bioperl-module-names 
			   nmspc nil t)))
	(setq pthn (cdr (bioperl-assoc-string mod name-list t)))
	(if (not pthn) 
	    (error "Shouldn't be here(1). Check `bioperl-module-path' and try running `bioperl-clear-module-cache'."))
	(if (not (string-match path-separator pthn))
	    ;; single path 
	    (setq pthn (string-to-number pthn))
	  ;; multiple paths (e.g., "0;1") - do completion
	  (let* (
		 (module-path 
		  (split-string bioperl-module-path path-separator))
		 (pthns (mapcar 'string-to-number
				(split-string pthn path-separator)))
		 (i -1)
		 (module-path-list 
		  (mapcar 
		   (lambda (x) (setq i (1+ i)) (list x i) )
		   module-path))
		 )
	    ;; filter list by pthns
	    (setq module-path-list
		  (delete nil (mapcar 
			       (lambda (x) (if (member (elt x 1) pthns) x nil))
			       module-path-list)))
	    (if (not module-path-list)
		(error "Shouldn't be here(2). Run `bioperl-clear-module-cache' and try again"))
	    (setq pthn (completing-read 
			(concat prompt-prefix nmspc "::" mod " Lib: ")
			module-path-list
			nil t (car (car module-path-list))))
	    (if (string-equal pthn "")
		(setq pthn (car (car module-path-list))))
	    (setq pthn (elt (bioperl-assoc-string pthn module-path-list t) 1))
	    )))
      ;; method completion
      (setq nmspc (replace-regexp-in-string "::$" "" nmspc))
      (unless (or (not done) (not (and nmspc mod)) (not get-method))
	;; path completion if necessary
	(if pthn
	    t
	  (setq pthn (cdr (bioperl-module-names nmspc nil t)))
	  (if (not (string-match path-separator pthn))
	      ;; single path
	      (setq pthn (string-to-number pthn))
	    ;; multiple paths (e.g., "0;1") - do completion
	    (let* (
		   (module-path 
		    (split-string bioperl-module-path path-separator))
		   (pthns (mapcar 'string-to-number
				  (split-string pthn path-separator)))
		   (i -1)
		   (module-path-list 
		    (mapcar 
		     (lambda (x) (setq i (1+ i)) (list x i) )
		     module-path))
		   )
	      ;; filter list by pthns
	      (setq module-path-list
		    (delete nil (mapcar 
				 (lambda (x) (if (member (elt x 1) pthns) x nil))
				 module-path-list)))
	      (if (not module-path-list)
		  (error "Shouldn't be here(3). Run `bioperl-clear-module-cache' and try again"))
	      (setq pthn (completing-read 
			  (concat prompt-prefix "Lib: ")
			  module-path-list
			nil t (car (car module-path-list))))
	      (if (string-equal pthn "")
		  (setq pthn (car (car module-path-list))))
	      (setq pthn (elt (bioperl-assoc-string pthn module-path-list t) 1))
	      )
	    ))
	(setq name-list (bioperl-method-names (concat nmspc "::" mod) t pthn))
	(let (
	      ;; local vars here...
	      )
	  (setq mth (completing-read
		     (concat prompt-prefix "Method in " nmspc "::" mod ": ")
		     name-list nil (not no-retry)))
	  (if (or no-retry (not (string-equal mth "")))
	      (setq done t)
	    ;; retry setup
	    ;; allow a backup into module completion
	    (setq done nil)
	    (let ( 
		  (splt (bioperl-split-name (concat nmspc "::" mod) nil pthn))
		  )
	      (setq nmspc (elt splt 0))
	      ;; kludge : "pretend" mod is not found using the "*"
	      (setq mod (concat "*" (elt splt 1))))))
	))
    ;; return values
    (if get-method
	(list nmspc mod mth pthn)
      (list nmspc mod pthn)) ))

(defun bioperl-namespace-completion-function (str pred flag)
  "A custom completion function for bioperl-mode.
Allows the lazy build of the `bioperl-module-names-cache' via `bioperl-make-collection' and `bioperl-module-names'."
  (if (not pred) 
      (setq pred 
	    (lambda (x) (setq x (if (listp x) (car x) x) ) (if (string-match "[a-zA-Z0-9_:]+" x) t nil))
	    ))
  (let (
	( collection (if (string-equal str "") '(("Bio" . nil )) (bioperl-make-collection str t)) )
	)
    ;; offer the right collection:
    ;; if collection was set, the str was complete and valid
    ;; if not, back up to the last :: in str (see str-trunc in above
    ;; let) and try again
   
    (if (not collection) 
	nil
      (setq collection (sort collection (lambda (x y) (string< (car x) (car y)))))
      (cond
       ((not (booleanp flag)) ;; 'lambda' or test-completion option
	;; this is a back-compat issue: emacs 21 will send 'lambda', 
	;; but doesn't have 'test-completion
	;;
	;; Note without test-completion, weird completion bugs can crop
        ;; up -- best upgrade to 22--
	(if (condition-case nil
		(symbol-function 'test-completion)
	      ('error nil))
	    (test-completion str collection pred)
	  collection
	  (try-completion str collection pred))
	)
       ( (not flag) ;; try-completion option
	   (try-completion str collection pred)
	   )
       ( flag ;; all-completion option
	   (all-completions str collection pred)
	   )
       ))))

(defun bioperl-make-collection (module-dir &optional retopt)
  "Create a completion collection for MODULE-DIR.
MODULE-DIR is in double-colon format, possibly with two trailing
colons.  RETOPT is as for `bioperl-module-names'.

This function searches all paths specified in
`bioperl-module-path'."