view release on metacpan or  search on metacpan

util/cperl-mode.el  view on Meta::CPAN

			 (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\\|class\\) " (car elt)) ; ss5
			    (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 "^[_a-zA-Z]+::" (car elt))
			 (string-match "^sub[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]" ; ss5: TODO: multi|proto submethods
				       (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 (EMX on OS/2) 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))))

(defun cperl-add-tags-recurse-noxs ()
  "Add to TAGS data for \"pure\" Perl files in the current directory and kids.
Use as
  emacs -batch -q -no-site-file -l emacs/cperl-mode.el \
        -f cperl-add-tags-recurse-noxs
"
  (cperl-write-tags nil nil t t nil t))

(defun cperl-add-tags-recurse-noxs-fullpath ()
  "Add to TAGS data for \"pure\" Perl in the current directory and kids.
Writes down fullpath, so TAGS is relocatable (but if the build directory
is relocated, the file TAGS inside it breaks). Use as
  emacs -batch -q -no-site-file -l emacs/cperl-mode.el \
        -f cperl-add-tags-recurse-noxs-fullpath
"
  (cperl-write-tags nil nil t t nil t ""))

(defun cperl-add-tags-recurse ()
  "Add to TAGS file data for Perl files in the current directory and kids.
Use as
  emacs -batch -q -no-site-file -l emacs/cperl-mode.el \
        -f cperl-add-tags-recurse
"
  (cperl-write-tags nil nil t t))

(defun cperl-write-tags (&optional file erase recurse dir inbuffer noxs topdir)
  ;; If INBUFFER, do not select buffer, and do not save
  ;; If ERASE is `ignore', do not erase, and do not try to delete old info.
  (require 'etags)
  (if file nil
    (setq file (if dir default-directory (buffer-file-name)))
    (if (and (not dir) (buffer-modified-p)) (error "Save buffer first!")))
  (or topdir
      (setq topdir default-directory))
  (let ((tags-file-name "TAGS")
	(case-fold-search (eq system-type 'emx))
	xs rel tm)
    (save-excursion
      (cond (inbuffer nil)		; Already there
	    ((file-exists-p tags-file-name)
	     (if cperl-xemacs-p
		 (visit-tags-table-buffer)
	       (visit-tags-table-buffer tags-file-name)))
	    (t (set-buffer (find-file-noselect tags-file-name))))
      (cond
       (dir
	(cond ((eq erase 'ignore))
	      (erase
	       (erase-buffer)
	       (setq erase 'ignore)))
	(let ((files
	       (condition-case err
		   (directory-files file t
				    (if recurse nil cperl-scan-files-regexp)
				    t)
		 (error
		  (if cperl-unreadable-ok nil
		    (if (y-or-n-p
			 (format "Directory %s unreadable.  Continue? " file))
			(setq cperl-unreadable-ok t
			      tm nil)	; Return empty list
		      (error "Aborting: unreadable directory %s" file)))))))
	  (mapcar (function
		   (lambda (file)
		     (cond
		      ((string-match cperl-noscan-files-regexp file)
		       nil)
		      ((not (file-directory-p file))
		       (if (string-match cperl-scan-files-regexp file)
			   (cperl-write-tags file erase recurse nil t noxs topdir)))
		      ((not recurse) nil)
		      (t (cperl-write-tags file erase recurse t t noxs topdir)))))