Tim Bunce > perl5.004_04 > emacs/cperl-mode.el

Download:
perl5.004_04.tar.gz

Annotate this POD

Source   Latest Release: perl-5.12.5

Top-level heading. =head2 Second-level heading. =head3 Third-level heading (is there such?). =over [ NUMBER ] Start list. =item [ TITLE ] Start new item in the list. =back End list. ^

(defun cperl-switch-to-doc-buffer () "Go to the perl documentation buffer and insert the documentation." (interactive) (let ((buf (get-buffer-create cperl-doc-buffer))) (if (interactive-p) (switch-to-buffer-other-window buf) (set-buffer buf)) (if (= (buffer-size) 0) (progn (insert (documentation-property 'cperl-short-docs 'variable-documentation)) (setq buffer-read-only t)))))

(defun cperl-beautify-regexp-piece (b e embed) ;; b is before the starting delimiter, e before the ending ;; e should be a marker, may be changed, but remains "correct". (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline code) (if (not embed) (goto-char (1+ b)) (goto-char b) (cond ((looking-at "(\\?\\\\#") ; badly commented (?#) (forward-char 2) (delete-char 1) (forward-char 1)) ((looking-at "(\\?[^a-zA-Z]") (forward-char 3)) ((looking-at "(\\?") ; (?i) (forward-char 2)) (t (forward-char 1)))) (setq c (if embed (current-indentation) (1- (current-column))) c1 (+ c (or cperl-regexp-indent-step cperl-indent-level))) (or (looking-at "[ \t]*[\n#]") (progn (insert "\n"))) (goto-char e) (beginning-of-line) (if (re-search-forward "[^ \t]" e t) (progn (goto-char e) (insert "\n") (indent-to-column c) (set-marker e (point)))) (goto-char b) (end-of-line 2) (while (< (point) (marker-position e)) (beginning-of-line) (setq s (point) inline t) (skip-chars-forward " \t") (delete-region s (point)) (indent-to-column c1) (while (and inline (looking-at (concat "\\([a-zA-Z0-9]+[^*+{?]\\)" ; 1 word "\\|" ; Embedded variable "\\$\\([a-zA-Z0-9_]+\\([[{]\\)?\\|[^\n \t)|]\\)" ; 2 3 "\\|" ; $ ^ "[$^]" "\\|" ; simple-code simple-code*? "\\(\\\\.\\|[^][()#|*+?\n]\\)\\([*+{?]\\??\\)?" ; 4 5 "\\|" ; Class "\\(\\[\\)" ; 6 "\\|" ; Grouping "\\((\\(\\?\\)?\\)" ; 7 8 "\\|" ; | "\\(|\\)" ; 9 ))) (goto-char (match-end 0)) (setq spaces t) (cond ((match-beginning 1) ; Alphanum word + junk (forward-char -1)) ((or (match-beginning 3) ; $ab[12] (and (match-beginning 5) ; X* X+ X{2,3} (eq (preceding-char) ?\{))) (forward-char -1) (forward-sexp 1)) ((match-beginning 6) ; [] (setq tmp (point)) (if (looking-at "\\^?\\]") (goto-char (match-end 0))) (or (re-search-forward "\\]\\([*+{?]\\)?" e t) (progn (goto-char (1- tmp)) (error "[]-group not terminated"))) (if (not (eq (preceding-char) ?\{)) nil (forward-char -1) (forward-sexp 1))) ((match-beginning 7) ; () (goto-char (match-beginning 0)) (or (eq (current-column) c1) (progn (insert "\n") (indent-to-column c1))) (setq tmp (point)) (forward-sexp 1) ;; (or (forward-sexp 1) ;; (progn ;; (goto-char tmp) ;; (error "()-group not terminated"))) (set-marker m (1- (point))) (set-marker m1 (point)) (cond ((not (match-beginning 8)) (cperl-beautify-regexp-piece tmp m t)) ((eq (char-after (+ 2 tmp)) ?\{) ; Code t) ((eq (char-after (+ 2 tmp)) ?\() ; Conditional (goto-char (+ 2 tmp)) (forward-sexp 1) (cperl-beautify-regexp-piece (point) m t)) (t (cperl-beautify-regexp-piece tmp m t))) (goto-char m1) (cond ((looking-at "[*+?]\\??") (goto-char (match-end 0))) ((eq (following-char) ?\{) (forward-sexp 1) (if (eq (following-char) ?\?) (forward-char)))) (skip-chars-forward " \t") (setq spaces nil) (if (looking-at "[#\n]") (progn (or (eolp) (indent-for-comment)) (beginning-of-line 2)) (insert "\n")) (end-of-line) (setq inline nil)) ((match-beginning 9) ; | (forward-char -1) (setq tmp (point)) (beginning-of-line) (if (re-search-forward "[^ \t]" tmp t) (progn (goto-char tmp) (insert "\n")) ;; first at line (delete-region (point) tmp)) (indent-to-column c) (forward-char 1) (skip-chars-forward " \t") (setq spaces nil) (if (looking-at "[#\n]") (beginning-of-line 2) (insert "\n")) (end-of-line) (setq inline nil))) (or (looking-at "[ \t\n]") (not spaces) (insert " ")) (skip-chars-forward " \t")) (or (looking-at "[#\n]") (error "unknown code \"%s\" in a regexp" (buffer-substring (point) (1+ (point))))) (and inline (end-of-line 2))) ;; Special-case the last line of group (if (and (>= (point) (marker-position e)) (/= (current-indentation) c)) (progn (beginning-of-line) (setq s (point)) (skip-chars-forward " \t") (delete-region s (point)) (indent-to-column c))) ))

(defun cperl-make-regexp-x () (save-excursion (or cperl-use-syntax-table-text-property (error "I need to have regex marked!")) ;; Find the start (re-search-backward "\\s|") ; Assume it is scanned already. ;;(forward-char 1) (let ((b (point)) (e (make-marker)) have-x delim (c (current-column)) (sub-p (eq (preceding-char) ?s)) s) (forward-sexp 1) (set-marker e (1- (point))) (setq delim (preceding-char)) (if (and sub-p (eq delim (char-after (- (point) 2)))) (error "Possible s/blah// - do not know how to deal with")) (if sub-p (forward-sexp 1)) (if (looking-at "\\sw*x") (setq have-x t) (insert "x")) ;; Protect fragile " ", "#" (if have-x nil (goto-char (1+ b)) (while (re-search-forward "\\(\\=\\|[^\\\\]\\)\\(\\\\\\\\\\)*[ \t\n#]" e t) ; Need to include (?#) too? (forward-char -1) (insert "\\") (forward-char 1))) b)))

(defun cperl-beautify-regexp () "do it. (Experimental, may change semantics, recheck the result.) We suppose that the regexp is scanned already." (interactive) (cperl-make-regexp-x) (re-search-backward "\\s|") ; Assume it is scanned already. ;;(forward-char 1) (let ((b (point)) (e (make-marker))) (forward-sexp 1) (set-marker e (1- (point))) (cperl-beautify-regexp-piece b e nil)))

(defun cperl-contract-level () "Find an enclosing group in regexp and contract it. (Experimental, may change semantics, recheck the result.) Unfinished. We suppose that the regexp is scanned already." (interactive) (let ((bb (cperl-make-regexp-x)) done) (while (not done) (or (eq (following-char) ?\() (search-backward "(" (1+ bb) t) (error "Cannot find `(' which starts a group")) (setq done (save-excursion (skip-chars-backward "\\") (looking-at "\\(\\\\\\\\\\)*("))) (or done (forward-char -1))) (let ((b (point)) (e (make-marker)) s c) (forward-sexp 1) (set-marker e (1- (point))) (goto-char b) (while (re-search-forward "\\(#\\)\\|\n" e t) (cond ((match-beginning 1) ; #-comment (or c (setq c (current-indentation))) (beginning-of-line 2) ; Skip (setq s (point)) (skip-chars-forward " \t") (delete-region s (point)) (indent-to-column c)) (t (delete-char -1) (just-one-space)))))))

(defun cperl-beautify-level () "Find an enclosing group in regexp and beautify it. (Experimental, may change semantics, recheck the result.) We suppose that the regexp is scanned already." (interactive) (let ((bb (cperl-make-regexp-x)) done) (while (not done) (or (eq (following-char) ?\() (search-backward "(" (1+ bb) t) (error "Cannot find `(' which starts a group")) (setq done (save-excursion (skip-chars-backward "\\") (looking-at "\\(\\\\\\\\\\)*("))) (or done (forward-char -1))) (let ((b (point)) (e (make-marker))) (forward-sexp 1) (set-marker e (1- (point))) (cperl-beautify-regexp-piece b e nil))))

(if (fboundp 'run-with-idle-timer) (progn (defvar cperl-help-shown nil "Non-nil means that the help was already shown now.")

      (defvar cperl-lazy-installed nil
        "Non-nil means that the lazy-help handlers are installed now.")

      (defun cperl-lazy-install ()
        (interactive)
        (make-variable-buffer-local 'cperl-help-shown)
        (if (and (cperl-val 'cperl-lazy-help-time)
                 (not cperl-lazy-installed))
            (progn
              (add-hook 'post-command-hook 'cperl-lazy-hook)
              (run-with-idle-timer 
               (cperl-val 'cperl-lazy-help-time 1000000 5) 
               t 
               'cperl-get-help-defer)
              (setq cperl-lazy-installed t))))

      (defun cperl-lazy-unstall ()
        (interactive)
        (remove-hook 'post-command-hook 'cperl-lazy-hook)
        (cancel-function-timers 'cperl-get-help-defer)
        (setq cperl-lazy-installed nil))

      (defun cperl-lazy-hook ()
        (setq cperl-help-shown nil))

      (defun cperl-get-help-defer ()
        (if (not (eq major-mode 'perl-mode)) nil
          (let ((cperl-message-on-help-error nil) (cperl-help-from-timer t))
            (cperl-get-help)
            (setq cperl-help-shown t))))
      (cperl-lazy-install)))

(provide 'cperl-mode)

syntax highlighting: