Function: cperl-find-tags

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

Signature

(cperl-find-tags IFILE XS TOPDIR)

Source Code

;; Defined in /usr/src/emacs/lisp/progmodes/cperl-mode.el.gz
(defun cperl-find-tags (ifile xs topdir)
  (let ((b (get-buffer cperl-tmp-buffer)) ind lst elt pos ret rel
	(cperl-pod-here-fontify nil) file)
    (save-excursion
      (if b (set-buffer b)
	(cperl-setup-tmp-buf))
      (erase-buffer)
      (condition-case nil
	  (setq file (car (insert-file-contents ifile)))
	(error (if cperl-unreadable-ok nil
		 (if (y-or-n-p
		      (format "File %s unreadable.  Continue? " ifile))
		     (setq cperl-unreadable-ok t)
		   (error "Aborting: unreadable file %s" ifile)))))
      (if (not file)
	  (message "Unreadable file %s" ifile)
	(message "Scanning file %s ..." file)
	(if (and cperl-use-syntax-table-text-property-for-tags
		 (not xs))
	    (condition-case err		; after __END__ may have garbage
		(cperl-find-pods-heres nil nil noninteractive)
	      (error (message "While scanning for syntax: %S" err))))
	(if xs
	    (setq lst (cperl-xsub-scan))
	  (setq ind (cperl-imenu--create-perl-index))
	  (setq lst (cdr (assoc "+Unsorted List+..." ind))))
	(setq lst
	      (mapcar
               (lambda (elt)
                 (cond ((string-match (rx line-start (or alpha "_")) (car elt))
                        (goto-char (cdr elt))
                        (beginning-of-line) ; pos should be of the start of the line
                        (list (car elt)
                              (point)
                              (1+ (count-lines 1 (point))) ; 1+ since at beg-o-l
                              (buffer-substring (progn
                                                  (goto-char (cdr elt))
                                                  ;; After name now...
                                                  (or (eolp) (forward-char 1))
                                                  (point))
                                                (progn
                                                  (beginning-of-line)
                                                  (point)))))))
	       lst))
	(erase-buffer)
	(while lst
	  (setq elt (car lst) lst (cdr lst))
	  (if elt
	      (progn
		(insert (elt elt 3)
			127
			(if (string-match "^package " (car elt))
			    (substring (car elt) 8)
			  (car elt) )
			1
			(number-to-string (elt elt 2)) ; Line
			","
			(number-to-string (1- (elt elt 1))) ; Char pos 0-based
			"\n")
		(if (and (string-match (rx line-start
                                           (eval cperl--basic-identifier-rx) "++")
                                       (car elt))
                         (string-match (rx-to-string `(sequence line-start
                                                                (regexp ,cperl-sub-regexp)
                                                                (1+ (in " \t"))
                                                                ,cperl--normal-identifier-rx))
                                       (elt elt 3)))
		    ;; Need to insert the name without package as well
		    (setq lst (cons (cons (substring (elt elt 3)
						     (match-beginning 1)
						     (match-end 1))
					  (cdr elt))
				    lst))))))
	(setq pos (point))
	(goto-char 1)
	(setq rel file)
	;; On case-preserving filesystems case might be encoded in properties
	(set-text-properties 0 (length rel) nil rel)
	(and (equal topdir (substring rel 0 (length topdir)))
	     (setq rel (substring file (length topdir))))
	(insert "\f\n" rel "," (number-to-string (1- pos)) "\n")
	(setq ret (buffer-substring 1 (point-max)))
	(erase-buffer)
	(or noninteractive
	    (message "Scanning file %s finished" file))
	ret))))