Gurusamy Sarathy > perl-5.6.0 > emacs/cperl-mode.el

Download:
perl-5.6.0.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)) ((eq (char-after (+ 2 tmp)) ?<) ; Lookbehind (goto-char (+ 3 tmp)) (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 () ;; Returns position of the start (save-excursion (or cperl-use-syntax-table-text-property (error "I need to have a regexp marked!")) ;; Find the start (if (looking-at "\\s|") nil ; good already (if (looking-at "\\([smy]\\|qr\\)\\s|") (forward-char 1) (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) (goto-char (cperl-make-regexp-x)) (let ((b (point)) (e (make-marker))) (forward-sexp 1) (set-marker e (1- (point))) (cperl-beautify-regexp-piece b e nil)))

(defun cperl-regext-to-level-start () "Goto start of an enclosing group in regexp. We suppose that the regexp is scanned already." (interactive) (let ((limit (cperl-make-regexp-x)) done) (while (not done) (or (eq (following-char) ?\() (search-backward "(" (1+ limit) t) (error "Cannot find `(' which starts a group")) (setq done (save-excursion (skip-chars-backward "\\") (looking-at "\\(\\\\\\\\\\)*("))) (or done (forward-char -1)))))

(defun cperl-contract-level () "Find an enclosing group in regexp and contract it. \(Experimental, may change semantics, recheck the result.) We suppose that the regexp is scanned already." (interactive) (cperl-regext-to-level-start) (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-contract-levels () "Find an enclosing group in regexp and contract all the kids. \(Experimental, may change semantics, recheck the result.) We suppose that the regexp is scanned already." (interactive) (condition-case nil (cperl-regext-to-level-start) (error ; We are outside outermost group (goto-char (cperl-make-regexp-x)))) (let ((b (point)) (e (make-marker)) s c) (forward-sexp 1) (set-marker e (1- (point))) (goto-char (1+ b)) (while (re-search-forward "\\(\\\\\\\\\\)\\|(" e t) (cond ((match-beginning 1) ; Skip nil) (t ; Group (cperl-contract-level))))))

(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) (cperl-regext-to-level-start) (let ((b (point)) (e (make-marker))) (forward-sexp 1) (set-marker e (1- (point))) (cperl-beautify-regexp-piece b e nil)))

(defun cperl-invert-if-unless () "Changes `if (A) {B}' into `B if A;' if possible." (interactive) (or (looking-at "\\<") (forward-sexp -1)) (if (looking-at "\\<\\(if\\|unless\\|while\\|until\\)\\>") (let ((pos1 (point)) pos2 pos3 pos4 pos5 s1 s2 state p pos45 (s0 (buffer-substring (match-beginning 0) (match-end 0)))) (forward-sexp 2) (setq pos3 (point)) (forward-sexp -1) (setq pos2 (point)) (if (eq (following-char) ?\( ) (progn (goto-char pos3) (forward-sexp 1) (setq pos5 (point)) (forward-sexp -1) (setq pos4 (point)) ;; XXXX In fact may be `A if (B); {C}' ... (if (and (eq (following-char) ?\{ ) (progn (cperl-backward-to-noncomment pos3) (eq (preceding-char) ?\) ))) (if (condition-case nil (progn (goto-char pos5) (forward-sexp 1) (forward-sexp -1) (looking-at "\\<els\\(e\\|if\\)\\>")) (error nil)) (error "`%s' (EXPR) {BLOCK} with `else'/`elsif'" s0) (goto-char (1- pos5)) (cperl-backward-to-noncomment pos4) (if (eq (preceding-char) ?\;) (forward-char -1)) (setq pos45 (point)) (goto-char pos4) (while (re-search-forward "\\<\\(for\\|foreach\\|if\\|unless\\|while\\|until\\)\\>\\|;" pos45 t) (setq p (match-beginning 0) s1 (buffer-substring p (match-end 0)) state (parse-partial-sexp pos4 p)) (or (nth 3 state) (nth 4 state) (nth 5 state) (error "`%s' inside `%s' BLOCK" s1 s0)) (goto-char (match-end 0))) ;; Finally got it (goto-char (1+ pos4)) (skip-chars-forward " \t\n") (setq s2 (buffer-substring (point) pos45)) (goto-char pos45) (or (looking-at ";?[ \t\n]*}") (progn (skip-chars-forward "; \t\n") (setq s2 (concat s2 "\n" (buffer-substring (point) (1- pos5)))))) (and (equal s2 "") (setq s2 "1")) (goto-char (1- pos3)) (cperl-backward-to-noncomment pos2) (or (looking-at "[ \t\n]*)") (goto-char (1- pos3))) (setq p (point)) (goto-char (1+ pos2)) (skip-chars-forward " \t\n") (setq s1 (buffer-substring (point) p)) (delete-region pos4 pos5) (delete-region pos2 pos3) (goto-char pos1) (insert s2 " ") (just-one-space) (forward-word 1) (setq pos1 (point)) (insert " " s1 ";") (forward-char -1) (delete-horizontal-space) (goto-char pos1) (just-one-space) (cperl-indent-line)) (error "`%s' (EXPR) not with an {BLOCK}" s0))) (error "`%s' not with an (EXPR)" s0))) (error "Not at `if', `unless', `while', or `unless'")))

;;; By Anthony Foiani <afoiani@uswest.com> ;;; Getting help on modules in C-h f ? ;;; Need to teach it how to lookup functions (defvar Man-filter-list) (defun cperl-perldoc (word) "Run a 'perldoc' on WORD." (interactive (list (let* ((default-entry (cperl-word-at-point)) (input (read-string (format "perldoc entry%s: " (if (string= default-entry "") "" (format " (default %s)" default-entry)))))) (if (string= input "") (if (string= default-entry "") (error "No perldoc args given") default-entry) input)))) (let* ((is-func (and (string-match "^[a-z]+$" word) (string-match (concat "^" word "\\>") (documentation-property 'cperl-short-docs 'variable-documentation)))) (manual-program (if is-func "perldoc -f" "perldoc"))) (require 'man) (Man-getpage-in-background word)))

(defun cperl-perldoc-at-point () "Run a 'perldoc' on WORD." (interactive) (cperl-perldoc (cperl-word-at-point)))

;;; By Nick Roberts <Nick.Roberts@src.bae.co.uk> (with changes) (defvar pod2man-program "pod2man")

(defun cperl-pod-to-manpage () "Create a virtual manpage in emacs from the Perl Online Documentation" (interactive) (require 'man) (let* ((pod2man-args (concat buffer-file-name " | nroff -man ")) (bufname (concat "Man " buffer-file-name)) (buffer (generate-new-buffer bufname))) (save-excursion (set-buffer buffer) (let ((process-environment (copy-sequence process-environment))) ;; Prevent any attempt to use display terminal fanciness. (setenv "TERM" "dumb") (set-process-sentinel (start-process pod2man-program buffer "sh" "-c" (format (cperl-pod2man-build-command) pod2man-args)) 'Man-bgproc-sentinel)))))

(defun cperl-pod2man-build-command () "Builds the entire background manpage and cleaning command." (let ((command (concat pod2man-program " %s 2>/dev/null")) (flist Man-filter-list)) (while (and flist (car flist)) (let ((pcom (car (car flist))) (pargs (cdr (car flist)))) (setq command (concat command " | " pcom " " (mapconcat '(lambda (phrase) (if (not (stringp phrase)) (error "Malformed Man-filter-list")) phrase) pargs " "))) (setq flist (cdr flist)))) command))

(defun cperl-lazy-install ()) ; Avoid a warning

(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)))

;;; Plug for wrong font-lock:

(defun cperl-font-lock-unfontify-region-function (beg end) (let* ((modified (buffer-modified-p)) (buffer-undo-list t) (inhibit-read-only t) (inhibit-point-motion-hooks t) before-change-functions after-change-functions deactivate-mark buffer-file-name buffer-file-truename) (remove-text-properties beg end '(face nil)) (when (and (not modified) (buffer-modified-p)) (set-buffer-modified-p nil))))

(defvar cperl-d-l nil) (defun cperl-fontify-syntaxically (end) ;; Some vars for debugging only (let (start (dbg (point)) (iend end) (istate (car cperl-syntax-state))) (and cperl-syntaxify-unwind (setq end (cperl-unwind-to-safe t end))) (setq start (point)) (or cperl-syntax-done-to (setq cperl-syntax-done-to (point-min))) (if (or (not (boundp 'font-lock-hot-pass)) (eval 'font-lock-hot-pass) t) ; Not debugged otherwise ;; Need to forget what is after `start' (setq start (min cperl-syntax-done-to start)) ;; Fontification without a change (setq start (max cperl-syntax-done-to start))) (and (> end start) (setq cperl-syntax-done-to start) ; In case what follows fails (cperl-find-pods-heres start end t nil t)) ;;(setq cperl-d-l (cons (format "Syntaxifying %s..%s from %s to %s\n" ;; dbg end start cperl-syntax-done-to) ;; cperl-d-l)) ;;(let ((standard-output (get-buffer "*Messages*"))) ;;(princ (format "Syntaxifying %s..%s from %s to %s\n" ;; dbg end start cperl-syntax-done-to))) (if (eq cperl-syntaxify-by-font-lock 'message) (message "Syntaxified %s..%s from %s to %s(%s), state %s-->%s" dbg iend start end cperl-syntax-done-to istate (car cperl-syntax-state))) ; For debugging nil)) ; Do not iterate

(defun cperl-fontify-update (end) (let ((pos (point)) prop posend) (while (< pos end) (setq prop (get-text-property pos 'cperl-postpone)) (setq posend (next-single-property-change pos 'cperl-postpone nil end)) (and prop (put-text-property pos posend (car prop) (cdr prop))) (setq pos posend))) nil) ; Do not iterate

(defun cperl-update-syntaxification (from to) (if (and cperl-use-syntax-table-text-property cperl-syntaxify-by-font-lock (or (null cperl-syntax-done-to) (< cperl-syntax-done-to to))) (progn (save-excursion (goto-char from) (cperl-fontify-syntaxically to)))))

(defvar cperl-version (let ((v "$Revision: 4.19 $")) (string-match ":\\s *\\([0-9.]+\\)" v) (substring v (match-beginning 1) (match-end 1))) "Version of IZ-supported CPerl package this file is based on.")

(provide 'cperl-mode)

;;; cperl-mode.el ends here

syntax highlighting: