view release on metacpan or  search on metacpan

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

	   )
       ))))

(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'."

  ;; handle the boundary
  (if (or (not module-dir) (not (string-match ":" module-dir)))
      '(("Bio") ("Bio::"))
    (setq module-dir (progn (string-match "^\\([a-zA-Z0-9_:]+[^:]\\):*$" module-dir)
			    (match-string 1 module-dir)))
    (let* (
	   ( dirs (bioperl-module-names module-dir retopt t) )
	   ( modules (split-string module-dir "::" t) )
	   ( complet ) 
	   )

      ;; check once and recalc
      (if (not dirs)
	  (progn 
	    ;; trim back to last ::
	    (setq module-dir
		  (progn 
		    (string-match  "^\\(\\(?:[a-zA-Z0-9_]+::\\)+\\)\\(?::*\\|[a-zA-Z0-9_]*\\)$" module-dir) 
		    (match-string 1 module-dir)))
	    (setq dirs (bioperl-module-names module-dir retopt t))
	    (setq modules (split-string module-dir "::" t))
	    ))
      (if (not dirs)
	  ;; fail
	  nil
	(setq complet (let* ( (l modules)
			      (m (list (pop l))) )
			(while l (push (concat (car m) "::" (pop l)) m))
			(mapcar (lambda (x) (cons x nil)) m ) ))
	;; make sure module-dir is trimmed
	(setq module-dir (replace-regexp-in-string "::$" "" module-dir))
	complet
	(append complet (mapcar (lambda (x) 
				  (list
				   (concat module-dir "::" (car x)) 
				   (cdr x))) dirs))
	))
      ))

;;
;; utilities
;;

(defun bioperl-clear-module-cache ()
  (interactive)
  "Clears the variable `bioperl-module-names-cache'. Run if you change `bioperl-module-path'."
  (setq bioperl-module-names-cache nil)
  (setq bioperl-module-names-cache '(("Bio"))))

; XEmacs compability for assoc-string (from http://web.mit.edu/shutkin/MacData_1124b/afs/athena/contrib/xemacs/share/xemacs-packages/lisp/calendar/cal-compat.el):
; thanks Adam
(if (fboundp 'assoc-string)
    (defalias 'bioperl-assoc-string 'assoc-string)
  (defun bioperl-assoc-string (key list case-fold)
    (if case-fold
        (bioperl-assoc-ignore-case key list)
      (assoc key list)))  
  )


;;
;; utilities (out of bioperl- namespace)
;;

    
(defun assoc-all (key alist &optional ret)
  "Return list of *pointers* (like assoc) to all matching conses in the alist.
Uses `bioperl-assoc-string' for case control."
  (let ( (c (bioperl-assoc-string key alist t)) ) 
    (if c 
	(assoc-all key (cdr alist) (if ret (add-to-list 'ret c t) (list c)))
      ret)))

(defun deep-assoc (keys alist)
  "Return the associations of a set of keys in an alist tree.
Uses `bioperl-assoc-string' for case control."
  (cond
   ((not keys) 
    nil)
   ((not (listp alist))
    nil)
   ((= (length keys) 1)
    (bioperl-assoc-string (pop keys) alist t))
   (t
    (let* ( (key (pop keys))
	    (newlist (bioperl-assoc-string key alist t)) ) 
      (if newlist
	  (deep-assoc keys (cdr newlist))
	(deep-assoc nil nil)))
    )))

(defun deep-assoc-all (keys alist)
  "Return all associations AT THE TIP described by the set of KEYS in an alist tree.
So this is not completely general, but is specialized to the structure of `bioperl-module-names-cache'."
  (cond
   ((not keys) 
    nil)
   ((not (listp alist))
    nil)
   ((= (length keys) 1)
    (assoc-all (pop keys) alist))
   (t
    (let* ( (key (pop keys))
	    (newlist (assoc-all key alist)) ) 
      (if newlist
	  (let ( ( i 0 ) (r)  )
	    (while (< i (length newlist))
	      (if (listp (cdr (elt newlist i)))
		  (setq r (deep-assoc-all keys (cdr (elt newlist i)))))
	      (setq i (1+ i)))