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. Unfinished. \(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. Unfinished. \(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) (and cperl-syntaxify-unwind (cperl-unwind-to-safe t)) (let ((start (point)) (dbg (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, state at %s" dbg end start cperl-syntax-done-to (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)))))

(provide 'cperl-mode)

;;; cperl-mode.el ends here