Function: cperl-imenu--create-perl-index

cperl-imenu--create-perl-index is an interactive and byte-compiled function defined in cperl-mode.el.gz.

Signature

(cperl-imenu--create-perl-index)

Documentation

Implement imenu-create-index-function for CPerl mode.

This function relies on syntaxification to exclude lines which look like declarations but actually are part of a string, a comment, or POD.

Key Bindings

Source Code

;; Defined in /usr/src/emacs/lisp/progmodes/cperl-mode.el.gz
(defun cperl-imenu--create-perl-index ()
  "Implement `imenu-create-index-function' for CPerl mode.
This function relies on syntaxification to exclude lines which
look like declarations but actually are part of a string, a
comment, or POD."
  (interactive) ; We'll remove that at some point
  (goto-char (point-min))
  (cperl-update-syntaxification (point-max))
  (let ((case-fold-search nil)
	(index-alist '())
	(index-package-alist '())
	(index-pod-alist '())
	(index-sub-alist '())
	(index-unsorted-alist '())
	(namespace-stack '())           ; for package NAME BLOCK
	(current-namespace "(main)")
	(current-namespace-end (point-max))) ; end of package scope
    ;; collect index entries
    (while (re-search-forward (rx (eval cperl--imenu-entries-rx)) nil t)
      ;; First, check whether we have left the scope of previously
      ;; recorded packages, and if so, eliminate them from the stack.
      (while (< current-namespace-end (point))
	(setq current-namespace (pop namespace-stack))
	(setq current-namespace-end (pop namespace-stack)))
      (let ((state (syntax-ppss))
            (entry-type (match-string 1))
	    name marker) ; for the "current" entry
	(cond
	 ((nth 3 state) nil)            ; matched in a string, so skip
         ((member entry-type cperl-imenu-package-keywords) ; package or class
	  (unless (nth 4 state)         ; skip if in a comment
	    (setq name (match-string-no-properties 2)
		  marker (copy-marker (match-end 2)))
	    (if  (string= (match-string 3) ";")
		(setq current-namespace name)  ; package NAME;
	      ;; No semicolon, therefore we have: package NAME BLOCK.
	      ;; Stash the current package, because we need to restore
	      ;; it after the end of BLOCK.
	      (push current-namespace-end namespace-stack)
	      (push current-namespace namespace-stack)
	      ;; record the current name and its scope
	      (setq current-namespace name)
	      (setq current-namespace-end (save-excursion
					  (goto-char (match-beginning 3))
					  (forward-sexp)
					  (point))))
	    (push (cons name marker) index-package-alist)
	    (push (cons (concat entry-type " " name) marker) index-unsorted-alist)))
	 ((or (member entry-type cperl-imenu-sub-keywords) ; sub or method
              (string-equal entry-type ""))                ; named blocks
	  (unless (nth 4 state)         ; skip if in a comment
	    (setq name (match-string-no-properties 2)
		  marker (copy-marker (match-end 2)))
	    ;; Qualify the sub name with the namespace if it doesn't
	    ;; already have one, and if it isn't lexically scoped.
	    ;; "my" and "state" subs are lexically scoped, but "our"
	    ;; are just lexical aliases to package subs.
	    (if (and (null (string-match "::" name))
		     (or (null (match-string 3))
			 (string-equal (match-string 3) "our")))
	      (setq name (concat current-namespace "::" name)))
	    (let ((index (cons name marker)))
	      (push index index-alist)
	      (push index index-sub-alist)
	      (push index index-unsorted-alist))))
	 ((member entry-type cperl-imenu-pod-keywords)  ; POD heading
	  (when (get-text-property (match-beginning 2) 'in-pod)
	    (setq name (concat (make-string
				(* 3 (- (char-after (match-beginning 3)) ?1))
				?\ )
			       (match-string-no-properties 2))
		  marker (copy-marker (match-beginning 2)))
	    (push (cons name marker) index-pod-alist)
	    (push (cons (concat "=" name) marker) index-unsorted-alist)))
	 (t (error "Unidentified match: %s" (match-string 0))))))
    ;; Now format the collected stuff
    (setq index-alist
	  (if (default-value 'imenu-sort-function)
	      (sort index-alist (default-value 'imenu-sort-function))
	    (nreverse index-alist)))
    (and index-pod-alist
	 (push (cons "+POD headers+..."
		     (nreverse index-pod-alist))
	       index-alist))
    (and (or index-package-alist index-sub-alist)
	 (let ((lst index-package-alist) hier-list pack elt group name)
	   ;; reverse and uniquify.
	   (while lst
	     (setq elt (car lst) lst (cdr lst) name (car elt))
	     (if (assoc name hier-list) nil
	       (setq hier-list (cons (cons name (cdr elt)) hier-list))))
	   (setq lst index-sub-alist)
	   (while lst
	     (setq elt (car lst) lst (cdr lst))
	     (cond ((string-match
                     (rx (sequence (or "::" "'")
                                   (eval cperl--basic-identifier-rx)
                                   string-end))
                     (car elt))
		    (setq pack (substring (car elt) 0 (match-beginning 0)))
		    (if (setq group (assoc pack hier-list))
			(if (listp (cdr group))
			    ;; Have some functions already
			    (setcdr group
				    (cons (cons (substring
						 (car elt)
						 (+ 2 (match-beginning 0)))
						(cdr elt))
					  (cdr group)))
			  (setcdr group (list (cons (substring
						     (car elt)
						     (+ 2 (match-beginning 0)))
						    (cdr elt)))))
		      (setq hier-list
			    (cons (cons pack
					(list (cons (substring
						     (car elt)
						     (+ 2 (match-beginning 0)))
						    (cdr elt))))
				  hier-list))))))
	   (push (cons "+Hierarchy+..."
		       hier-list)
		 index-alist)))
    (and index-package-alist
	 (push (cons "+Classes,Packages+..."
		     (nreverse index-package-alist))
	       index-alist))
    (and (or index-package-alist index-pod-alist
	     (default-value 'imenu-sort-function))
	 index-unsorted-alist
	 (push (cons "+Unsorted List+..."
		     (nreverse index-unsorted-alist))
	       index-alist))
    ;; Finally, return the whole collection
    index-alist))