Function: cperl-tags-treeify

cperl-tags-treeify is a byte-compiled function defined in cperl-mode.el.gz.

Signature

(cperl-tags-treeify TO LEVEL)

Source Code

;; Defined in /usr/src/emacs/lisp/progmodes/cperl-mode.el.gz
(defun cperl-tags-treeify (to level)
  ;; cadr of `to' is read-write.  On start it is a cons
  (let* ((regexp (concat "^\\(" (mapconcat
				 #'identity
				 (make-list level "[_a-zA-Z0-9]+")
				 "::")
			 "\\)\\(::\\)?"))
	 (packages (cdr (nth 1 to)))
	 (methods (cdr (nth 2 to)))
	 head cons1 cons2 ord writeto recurse ;; l1
	 root-packages root-functions
	 (move-deeper
          (lambda (elt)
            (cond ((and (string-match regexp (car elt))
                        (or (eq ord 1) (match-end 2)))
                   (setq head (substring (car elt) 0 (match-end 1))
                         recurse t)
                   (if (setq cons1 (assoc head writeto)) nil
                     ;; Need to init new head
                     (setcdr writeto (cons (list head (list "Packages: ")
                                                 (list "Methods: "))
                                           (cdr writeto)))
                     (setq cons1 (nth 1 writeto)))
                   (setq cons2 (nth ord cons1)) ; Either packs or meths
                   (setcdr cons2 (cons elt (cdr cons2))))
                  ((eq ord 2)
                   (setq root-functions (cons elt root-functions)))
                  (t
                   (setq root-packages (cons elt root-packages)))))))
    (setcdr to nil) ;; l1		; Init to dynamic space
    (setq writeto to)
    (setq ord 1)
    (mapc move-deeper packages)
    (setq ord 2)
    (mapc move-deeper methods)
    (if recurse
        (mapc (lambda (elt)
                (cperl-tags-treeify elt (1+ level)))
	      (cdr to)))
    ;;Now clean up leaders with one child only
    (mapc (lambda (elt)
            (if (not (and (listp (cdr elt))
                          (eq (length elt) 2)))
                nil
              (setcar elt (car (nth 1 elt)))
              (setcdr elt (cdr (nth 1 elt)))))
	  (cdr to))
    ;; Sort the roots of subtrees
    (if (default-value 'imenu-sort-function)
	(setcdr to
		(sort (cdr to) (default-value 'imenu-sort-function))))
    ;; Now add back functions removed from display
    (mapc (lambda (elt)
            (setcdr to (cons elt (cdr to))))
	  (if (default-value 'imenu-sort-function)
	      (nreverse
	       (sort root-functions (default-value 'imenu-sort-function)))
	    root-functions))
    ;; Now add back packages removed from display
    (mapc (lambda (elt)
            (setcdr to (cons (cons (concat "package " (car elt))
                                   (cdr elt))
                             (cdr to))))
	  (if (default-value 'imenu-sort-function)
	      (nreverse
	       (sort root-packages (default-value 'imenu-sort-function)))
	    root-packages))))