(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 level) ;; b is before the starting delimiter, e before the ending ;; e should be a marker, may be changed, but remains "correct". ;; EMBED is nil iff we process the whole REx. ;; The REx is guaranteed to have //x ;; LEVEL shows how many levels deep to go ;; position at enter and at leave is not defined (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline code pos) (if (not embed) (goto-char (1+ b)) (goto-char b) (cond ((looking-at "(\\?\\\\#") ; (?#) wrongly commented when //x-ing (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 ; Something before the ending delimiter (goto-char e) (delete-horizontal-space) (insert "\n") (cperl-make-indent 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)) (cperl-make-indent 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)) ((and ; [], already syntaxified (match-beginning 6) cperl-regexp-scan cperl-use-syntax-table-text-property) (forward-char -1) (forward-sexp 1) (or (eq (preceding-char) ?\]) (error "[]-group not terminated")) (re-search-forward "\\=\\([*+?]\\|{[0-9]+\\(,[0-9]*\\)?}\\)\\??" e t)) ((match-beginning 6) ; [] (setq tmp (point)) (if (looking-at "\\^?\\]") (goto-char (match-end 0))) ;; XXXX POSIX classes?! (while (and (not pos) (re-search-forward "\\[:\\|\\]" e t)) (if (eq (preceding-char) ?:) (or (re-search-forward ":\\]" e t) (error "[:POSIX:]-group in []-group not terminated")) (setq pos t))) (or (eq (preceding-char) ?\]) (error "[]-group not terminated")) (re-search-forward "\\=\\([*+?]\\|{[0-9]+\\(,[0-9]*\\)?}\\)\\??" e t)) ((match-beginning 7) ; () (goto-char (match-beginning 0)) (setq pos (current-column)) (or (eq pos c1) (progn (delete-horizontal-space) (insert "\n") (cperl-make-indent 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)) (if (= level 1) (if (progn ; indent rigidly if multiline ;; In fact does not make a lot of sense, since ;; the starting position can be already lost due ;; to insertion of "\n" and " " (goto-char tmp) (search-forward "\n" m1 t)) (indent-rigidly (point) m1 (- c1 pos))) (setq level (1- level)) (cond ((not (match-beginning 8)) (cperl-beautify-regexp-piece tmp m t level)) ((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 level)) ((eq (char-after (+ 2 tmp)) ?<) ; Lookbehind (goto-char (+ 3 tmp)) (cperl-beautify-regexp-piece (point) m t level)) (t (cperl-beautify-regexp-piece tmp m t level)))) (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)) (delete-horizontal-space) (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) (delete-horizontal-space) (insert "\n")) ;; first at line (delete-region (point) tmp)) (cperl-make-indent c) (forward-char 1) (skip-chars-forward " \t") (setq spaces nil) (if (looking-at "[#\n]") (beginning-of-line 2) (delete-horizontal-space) (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) (cperl-make-indent c)))))
(defun cperl-make-regexp-x () ;; Returns position of the start ;; XXX this is called too often! Need to cache the result! (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 (&optional deep) "Do it. (Experimental, may change semantics, recheck the result.) We suppose that the regexp is scanned already." (interactive "P") (setq deep (if deep (prefix-numeric-value deep) -1)) (save-excursion (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 deep))))
(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) ;; (save-excursion ; Can't, breaks `cperl-contract-levels' (cperl-regext-to-level-start) (let ((b (point)) (e (make-marker)) c) (forward-sexp 1) (set-marker e (1- (point))) (goto-char b) (while (re-search-forward "\\(#\\)\\|\n" e 'to-end) (cond ((match-beginning 1) ; #-comment (or c (setq c (current-indentation))) (beginning-of-line 2) ; Skip (cperl-make-indent 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) (save-excursion (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 (&optional deep) "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 "P") (setq deep (if deep (prefix-numeric-value deep) -1)) (save-excursion (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 deep))))
(defun cperl-invert-if-unless-modifiers () "Change `B if A;' into `if (A) {B}' etc if possible. \(Unfinished.)" (interactive) ; (let (A B pre-B post-B pre-if post-if pre-A post-A if-string (w-rex "\\<\\(if\\|unless\\|while\\|until\\|for\\|foreach\\)\\>")) (and (= (char-syntax (preceding-char)) ?w) (forward-sexp -1)) (setq pre-if (point)) (cperl-backward-to-start-of-expr) (setq pre-B (point)) (forward-sexp 1) ; otherwise forward-to-end-of-expr is NOP (cperl-forward-to-end-of-expr) (setq post-A (point)) (goto-char pre-if) (or (looking-at w-rex) ;; Find the position (progn (goto-char post-A) (while (and (not (looking-at w-rex)) (> (point) pre-B)) (forward-sexp -1)) (setq pre-if (point)))) (or (looking-at w-rex) (error "Can't find `if', `unless', `while', `until', `for' or `foreach'")) ;; 1 B 2 ... 3 B-com ... 4 if 5 ... if-com 6 ... 7 A 8 (setq if-string (buffer-substring (match-beginning 0) (match-end 0))) ;; First, simple part: find code boundaries (forward-sexp 1) (setq post-if (point)) (forward-sexp -2) (forward-sexp 1) (setq post-B (point)) (cperl-backward-to-start-of-expr) (setq pre-B (point)) (setq B (buffer-substring pre-B post-B)) (goto-char pre-if) (forward-sexp 2) (forward-sexp -1) ;; May be after $, @, $# etc of a variable (skip-chars-backward "$@%#") (setq pre-A (point)) (cperl-forward-to-end-of-expr) (setq post-A (point)) (setq A (buffer-substring pre-A post-A)) ;; Now modify (from end, to not break the stuff) (skip-chars-forward " \t;") (delete-region pre-A (point)) ; we move to pre-A (insert "\n" B ";\n}") (and (looking-at "[ \t]*#") (cperl-indent-for-comment)) (delete-region pre-if post-if) (delete-region pre-B post-B) (goto-char pre-B) (insert if-string " (" A ") {") (setq post-B (point)) (if (looking-at "[ \t]+$") (delete-horizontal-space) (if (looking-at "[ \t]*#") (cperl-indent-for-comment) (just-one-space))) (forward-line 1) (if (looking-at "[ \t]*$") (progn ; delete line (delete-horizontal-space) (delete-region (point) (1+ (point))))) (cperl-indent-line) (goto-char (1- post-B)) (forward-sexp 1) (cperl-indent-line) (goto-char pre-B)))
(defun cperl-invert-if-unless () "Change `if (A) {B}' into `B if A;' etc (or visa versa) if possible. If the cursor is not on the leading keyword of the BLOCK flavor of construct, will assume it is the STATEMENT flavor, so will try to find the appropriate statement modifier." (interactive) (and (= (char-syntax (preceding-char)) ?w) (forward-sexp -1)) (if (looking-at "\\<\\(if\\|unless\\|while\\|until\\|for\\|foreach\\)\\>") (let ((pre-if (point)) pre-A post-A pre-B post-B A B state p end-B-code is-block B-comment (if-string (buffer-substring (match-beginning 0) (match-end 0)))) (forward-sexp 2) (setq post-A (point)) (forward-sexp -1) (setq pre-A (point)) (setq is-block (and (eq (following-char) ?\( ) (save-excursion (condition-case nil (progn (forward-sexp 2) (forward-sexp -1) (eq (following-char) ?\{ )) (error nil))))) (if is-block (progn (goto-char post-A) (forward-sexp 1) (setq post-B (point)) (forward-sexp -1) (setq pre-B (point)) (if (and (eq (following-char) ?\{ ) (progn (cperl-backward-to-noncomment post-A) (eq (preceding-char) ?\) ))) (if (condition-case nil (progn (goto-char post-B) (forward-sexp 1) (forward-sexp -1) (looking-at "\\<els\\(e\\|if\\)\\>")) (error nil)) (error "`%s' (EXPR) {BLOCK} with `else'/`elsif'" if-string) (goto-char (1- post-B)) (cperl-backward-to-noncomment pre-B) (if (eq (preceding-char) ?\;) (forward-char -1)) (setq end-B-code (point)) (goto-char pre-B) (while (re-search-forward "\\<\\(for\\|foreach\\|if\\|unless\\|while\\|until\\)\\>\\|;" end-B-code t) (setq p (match-beginning 0) A (buffer-substring p (match-end 0)) state (parse-partial-sexp pre-B p)) (or (nth 3 state) (nth 4 state) (nth 5 state) (error "`%s' inside `%s' BLOCK" A if-string)) (goto-char (match-end 0))) ;; Finally got it (goto-char (1+ pre-B)) (skip-chars-forward " \t\n") (setq B (buffer-substring (point) end-B-code)) (goto-char end-B-code) (or (looking-at ";?[ \t\n]*}") (progn (skip-chars-forward "; \t\n") (setq B-comment (buffer-substring (point) (1- post-B))))) (and (equal B "") (setq B "1")) (goto-char (1- post-A)) (cperl-backward-to-noncomment pre-A) (or (looking-at "[ \t\n]*)") (goto-char (1- post-A))) (setq p (point)) (goto-char (1+ pre-A)) (skip-chars-forward " \t\n") (setq A (buffer-substring (point) p)) (delete-region pre-B post-B) (delete-region pre-A post-A) (goto-char pre-if) (insert B " ") (and B-comment (insert B-comment " ")) (just-one-space) (forward-word 1) (setq pre-A (point)) (insert " " A ";") (delete-horizontal-space) (setq post-B (point)) (if (looking-at "#") (indent-for-comment)) (goto-char post-B) (forward-char -1) (delete-horizontal-space) (goto-char pre-A) (just-one-space) (goto-char pre-if) (setq pre-A (set-marker (make-marker) pre-A)) (while (<= (point) (marker-position pre-A)) (cperl-indent-line) (forward-line 1)) (goto-char (marker-position pre-A)) (if B-comment (progn (forward-line -1) (indent-for-comment) (goto-char (marker-position pre-A))))) (error "`%s' (EXPR) not with an {BLOCK}" if-string))) ;; (error "`%s' not with an (EXPR)" if-string) (forward-sexp -1) (cperl-invert-if-unless-modifiers))) ;;(error "Not at `if', `unless', `while', `until', `for' or `foreach'") (cperl-invert-if-unless-modifiers)))
;;; By Anthony Foiani <afoiani@uswest.com> ;;; Getting help on modules in C-h f ? ;;; This is a modified version of `man'. ;;; Need to teach it how to lookup functions ;;;###autoload (defun cperl-perldoc (word) "Run `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)))) (require 'man) (let* ((case-fold-search nil) (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"))) (cond (cperl-xemacs-p (let ((Manual-program "perldoc") (Manual-switches (if is-func (list "-f")))) (manual-entry word))) (t (Man-getpage-in-background word)))))
;;;###autoload (defun cperl-perldoc-at-point () "Run a `perldoc' on the word around point." (interactive) (cperl-perldoc (cperl-word-at-point)))
(defcustom pod2man-program "pod2man" "*File name for `pod2man'." :type 'file :group 'cperl)
;;; By Nick Roberts <Nick.Roberts@src.bae.co.uk> (with changes) (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)))))
;;; Updated version by him too (defun cperl-build-manpage () "Create a virtual manpage in Emacs from the POD in the file." (interactive) (require 'man) (cond (cperl-xemacs-p (let ((Manual-program "perldoc")) (manual-entry buffer-file-name))) (t (let* ((manual-program "perldoc")) (Man-getpage-in-background buffer-file-name)))))
(defun cperl-pod2man-build-command () "Builds the entire background manpage and cleaning command." (let ((command (concat pod2man-program " %s 2>/dev/null")) (flist (and (boundp 'Man-filter-list) 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-next-interpolated-REx-1 () "Move point to next REx which has interpolated parts without //o. Skips RExes consisting of one interpolated variable.
Note that skipped RExen are not performance hits." (interactive "") (cperl-next-interpolated-REx 1))
(defun cperl-next-interpolated-REx-0 () "Move point to next REx which has interpolated parts without //o." (interactive "") (cperl-next-interpolated-REx 0))
(defun cperl-next-interpolated-REx (&optional skip beg limit) "Move point to next REx which has interpolated parts. SKIP is a list of possible types to skip, BEG and LIMIT are the starting point and the limit of search (default to point and end of buffer).
SKIP may be a number, then it behaves as list of numbers up to SKIP; this semantic may be used as a numeric argument.
Types are 0 for / $rex /o (interpolated once), 1 for /$rex/ (if $rex is a result of qr//, this is not a performance hit), t for the rest." (interactive "P") (if (numberp skip) (setq skip (list 0 skip))) (or beg (setq beg (point))) (or limit (setq limit (point-max))) ; needed for n-s-p-c (let (pp) (and (eq (get-text-property beg 'syntax-type) 'string) (setq beg (next-single-property-change beg 'syntax-type nil limit))) (cperl-map-pods-heres (function (lambda (s e p) (if (memq (get-text-property s 'REx-interpolated) skip) t (setq pp s) nil))) ; nil stops 'REx-interpolated beg limit) (if pp (goto-char pp) (message "No more interpolated REx"))))
;;; Initial version contributed by Trey Belew (defun cperl-here-doc-spell (&optional beg end) "Spell-check HERE-documents in the Perl buffer. If a region is highlighted, restricts to the region." (interactive "") (cperl-pod-spell t beg end))
(defun cperl-pod-spell (&optional do-heres beg end) "Spell-check POD documentation. If invoked with prefix argument, will do HERE-DOCs instead. If a region is highlighted, restricts to the region." (interactive "P") (save-excursion (let (beg end) (if (cperl-mark-active) (setq beg (min (mark) (point)) end (max (mark) (point))) (setq beg (point-min) end (point-max))) (cperl-map-pods-heres (function (lambda (s e p) (if do-heres (setq e (save-excursion (goto-char e) (forward-line -1) (point)))) (ispell-region s e) t)) (if do-heres 'here-doc-group 'in-pod) beg end))))
(defun cperl-map-pods-heres (func &optional prop s end) "Executes a function over regions of pods or here-documents. PROP is the text-property to search for; default to `in-pod'. Stop when function returns nil." (let (pos posend has-prop (cont t)) (or prop (setq prop 'in-pod)) (or s (setq s (point-min))) (or end (setq end (point-max))) (cperl-update-syntaxification end end) (save-excursion (goto-char (setq pos s)) (while (and cont (< pos end)) (setq has-prop (get-text-property pos prop)) (setq posend (next-single-property-change pos prop nil end)) (and has-prop (setq cont (funcall func pos posend prop))) (setq pos posend)))))
;;; Based on code by Masatake YAMATO: (defun cperl-get-here-doc-region (&optional pos pod) "Return HERE document region around the point. Return nil if the point is not in a HERE document region. If POD is non-nil, will return a POD section if point is in a POD section." (or pos (setq pos (point))) (cperl-update-syntaxification pos pos) (if (or (eq 'here-doc (get-text-property pos 'syntax-type)) (and pod (eq 'pod (get-text-property pos 'syntax-type)))) (let ((b (cperl-beginning-of-property pos 'syntax-type)) (e (next-single-property-change pos 'syntax-type))) (cons b (or e (point-max))))))
(defun cperl-narrow-to-here-doc (&optional pos) "Narrows editing region to the HERE-DOC at POS. POS defaults to the point." (interactive "d") (or pos (setq pos (point))) (let ((p (cperl-get-here-doc-region pos))) (or p (error "Not inside a HERE document")) (narrow-to-region (car p) (cdr p)) (message "When you are finished with narrow editing, type C-x n w")))
(defun cperl-select-this-pod-or-here-doc (&optional pos) "Select the HERE-DOC (or POD section) at POS. POS defaults to the point." (interactive "d") (let ((p (cperl-get-here-doc-region pos t))) (if p (progn (goto-char (car p)) (push-mark (cdr p) nil t)) ; Message, activate in transient-mode (message "I do not think POS is in POD or a HERE-doc..."))))
(defun cperl-facemenu-add-face-function (face end) "A callback to process user-initiated font-change requests. Translates `bold', `italic', and `bold-italic' requests to insertion of corresponding POD directives, and `underline' to POD directive.
Such requests are usually bound to M-o LETTER." (or (get-text-property (point) 'in-pod) (error "Faces can only be set within POD")) (setq facemenu-end-add-face (if (eq face 'bold-italic) ">>" ">")) (cdr (or (assq face '((bold . "") (italic . "") (bold-italic . "") (underline . ""))) (error "Face %s not configured for cperl-mode" face))))
"))) (error "Face %s not configured for cperl-mode" face))))
(defun cperl-time-fontification (&optional l step lim) "Times how long it takes to do incremental fontification in a region. L is the line to start at, STEP is the number of lines to skip when doing next incremental fontification, LIM is the maximal number of incremental fontification to perform. Messages are accumulated in *Messages* buffer.
May be used for pinpointing which construct slows down buffer fontification: start with default arguments, then refine the slowdown regions." (interactive "nLine to start at: \nnStep to do incremental fontification: ") (or l (setq l 1)) (or step (setq step 500)) (or lim (setq lim 40)) (let* ((timems (function (lambda () (let ((tt (current-time))) (+ (* 1000 (nth 1 tt)) (/ (nth 2 tt) 1000)))))) (tt (funcall timems)) (c 0) delta tot) (goto-line l) (cperl-mode) (setq tot (- (- tt (setq tt (funcall timems))))) (message "cperl-mode at %s: %s" l tot) (while (and (< c lim) (not (eobp))) (forward-line step) (setq l (+ l step)) (setq c (1+ c)) (cperl-update-syntaxification (point) (point)) (setq delta (- (- tt (setq tt (funcall timems)))) tot (+ tot delta)) (message "to %s:%6s,%7s" l delta tot)) tot))
(defun cperl-emulate-lazy-lock (&optional window-size) "Emulate `lazy-lock' without `condition-case', so `debug-on-error' works. Start fontifying the buffer from the start (or end) using the given WINDOW-SIZE (units is lines). Negative WINDOW-SIZE starts at end, and goes backwards; default is -50. This function is not CPerl-specific; it may be used to debug problems with delayed incremental fontification." (interactive "nSize of window for incremental fontification, negative goes backwards: ") (or window-size (setq window-size -50)) (let ((pos (if (> window-size 0) (point-min) (point-max))) p) (goto-char pos) (normal-mode) ;; Why needed??? With older font-locks??? (set (make-local-variable 'font-lock-cache-position) (make-marker)) (while (if (> window-size 0) (< pos (point-max)) (> pos (point-min))) (setq p (progn (forward-line window-size) (point))) (font-lock-fontify-region (min p pos) (max p pos)) (setq pos p))))
(defun cperl-lazy-install ()) ; Avoid a warning (defun cperl-lazy-unstall ()) ; 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 () "Switches on Auto-Help on Perl constructs (put in the message area). Delay of auto-help controlled by `cperl-lazy-help-time'." (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 () "Switches off Auto-Help on Perl constructs (put in the message area). Delay of auto-help controlled by `cperl-lazy-help-time'." (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 (memq major-mode '(perl-mode cperl-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)) (if (and (not modified) (buffer-modified-p)) (set-buffer-modified-p nil))))
(defun cperl-font-lock-fontify-region-function (beg end loudly) "Extends the region to safe positions, then calls the default function. Newer `font-lock's can do it themselves. We unwind only as far as needed for fontification. Syntaxification may do extra unwind via `cperl-unwind-to-safe'." (save-excursion (goto-char beg) (while (and beg (progn (beginning-of-line) (eq (get-text-property (setq beg (point)) 'syntax-type) 'multiline))) (if (setq beg (cperl-beginning-of-property beg 'syntax-type)) (goto-char beg))) (setq beg (point)) (goto-char end) (while (and end (progn (or (bolp) (condition-case nil (forward-line 1) (error nil))) (eq (get-text-property (setq end (point)) 'syntax-type) 'multiline))) (setq end (next-single-property-change end 'syntax-type nil (point-max))) (goto-char end)) (setq end (point))) (font-lock-default-fontify-region beg end loudly))
(defvar cperl-d-l nil) (defun cperl-fontify-syntaxically (end) ;; Some vars for debugging only ;; (message "Syntaxifying...") (let ((dbg (point)) (iend end) (idone cperl-syntax-done-to) (istate (car cperl-syntax-state)) start from-start edebug-backtrace-buffer) (if (eq cperl-syntaxify-by-font-lock 'backtrace) (progn (require 'edebug) (let ((f 'edebug-backtrace)) (funcall f)))) ; Avoid compile-time warning (or cperl-syntax-done-to (setq cperl-syntax-done-to (point-min) from-start t)) (setq start (if (and cperl-hook-after-change (not from-start)) cperl-syntax-done-to ; Fontify without change; ignore start ;; Need to forget what is after `start' (min cperl-syntax-done-to (point)))) (goto-char start) (beginning-of-line) (setq start (point)) (and cperl-syntaxify-unwind (setq end (cperl-unwind-to-safe t end) start (point))) (and (> end start) (setq cperl-syntax-done-to start) ; In case what follows fails (cperl-find-pods-heres start end t nil t)) (if (memq cperl-syntaxify-by-font-lock '(backtrace message)) (message "Syxify req=%s..%s actual=%s..%s done-to: %s=>%s statepos: %s=>%s" dbg iend start end idone cperl-syntax-done-to istate (car cperl-syntax-state))) ; For debugging nil)) ; Do not iterate
(defun cperl-fontify-update (end) (let ((pos (point-min)) prop posend) (setq end (point-max)) (while (< pos end) (setq prop (get-text-property pos 'cperl-postpone) 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-fontify-update-bad (end) ;; Since fontification happens with different region than syntaxification, ;; do to the end of buffer, not to END;;; likewise, start earlier if needed (let* ((pos (point)) (prop (get-text-property pos 'cperl-postpone)) posend) (if prop (setq pos (or (cperl-beginning-of-property (cperl-1+ pos) 'cperl-postpone) (point-min)))) (while (< pos end) (setq posend (next-single-property-change pos 'cperl-postpone)) (and prop (put-text-property pos posend (car prop) (cdr prop))) (setq pos posend) (setq prop (get-text-property pos 'cperl-postpone)))) nil) ; Do not iterate
;; Called when any modification is made to buffer text. (defun cperl-after-change-function (beg end old-len) ;; We should have been informed about changes by `font-lock'. Since it ;; does not inform as which calls are defered, do it ourselves (if cperl-syntax-done-to (setq cperl-syntax-done-to (min cperl-syntax-done-to beg))))
(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: 5.23 $")) (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
2 POD Errors
The following errors were encountered while parsing the POD:
=pod directives shouldn't be over one line long! Ignoring all 2 lines of content
Unterminated B<I<B<I<C<...>>>>> sequence
To install Env, copy and paste the appropriate command in to your terminal.
cpanm
cpanm Env
CPAN shell
perl -MCPAN -e shell install Env
For more information on module installation, please visit the detailed CPAN module installation guide.