TTY Internet Solutions > kurila-1.19_0 > emacs/kurila-mode.el


Annotate this POD


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 kurila-switch-to-doc-buffer () "Go to the perl documentation buffer and insert the documentation." (interactive) (let ((buf (get-buffer-create kurila-doc-buffer))) (if (interactive-p) (switch-to-buffer-other-window buf) (set-buffer buf)) (if (= (buffer-size) 0) (progn (insert (documentation-property 'kurila-short-docs 'variable-documentation)) (setq buffer-read-only t)))))

(defun kurila-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 kurila-regexp-indent-step kurila-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") (kurila-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)) (kurila-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) kurila-regexp-scan kurila-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") (kurila-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)) (kurila-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) (kurila-beautify-regexp-piece (point) m t level)) ((eq (char-after (+ 2 tmp)) ?<) ; Lookbehind (goto-char (+ 3 tmp)) (kurila-beautify-regexp-piece (point) m t level)) (t (kurila-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)) (kurila-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) (kurila-make-indent c)))))

(defun kurila-make-regexp-x () ;; Returns position of the start ;; XXX this is called too often! Need to cache the result! (save-excursion (or kurila-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 kurila-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 (kurila-make-regexp-x)) (let ((b (point)) (e (make-marker))) (forward-sexp 1) (set-marker e (1- (point))) (kurila-beautify-regexp-piece b e nil deep))))

(defun kurila-regext-to-level-start () "Goto start of an enclosing group in regexp. We suppose that the regexp is scanned already." (interactive) (let ((limit (kurila-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 kurila-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 `kurila-contract-levels' (kurila-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 (kurila-make-indent c)) (t (delete-char -1) (just-one-space))))))

(defun kurila-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 (kurila-regext-to-level-start) (error ; We are outside outermost group (goto-char (kurila-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 (kurila-contract-level)))))))

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

(defun kurila-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)) (kurila-backward-to-start-of-expr) (setq pre-B (point)) (forward-sexp 1) ; otherwise forward-to-end-of-expr is NOP (kurila-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)) (kurila-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)) (kurila-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]*#") (kurila-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]*#") (kurila-indent-for-comment) (just-one-space))) (forward-line 1) (if (looking-at "[ \t]*$") (progn ; delete line (delete-horizontal-space) (delete-region (point) (1+ (point))))) (kurila-indent-line) (goto-char (1- post-B)) (forward-sexp 1) (kurila-indent-line) (goto-char pre-B)))

(defun kurila-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 (kurila-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)) (kurila-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)) (kurila-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)) (kurila-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) (kurila-invert-if-unless-modifiers))) ;;(error "Not at `if', `unless', `while', `until', `for' or `foreach'") (kurila-invert-if-unless-modifiers)))

;;; By Anthony Foiani <> ;;; 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 kurila-perldoc (word) "Run `perldoc' on WORD." (interactive (list (let* ((default-entry (kurila-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 'kurila-short-docs 'variable-documentation)))) (manual-program (if is-func "perldoc -f" "perldoc"))) (cond (kurila-xemacs-p (let ((Manual-program "perldoc") (Manual-switches (if is-func (list "-f")))) (manual-entry word))) (t (Man-getpage-in-background word)))))

;;;###autoload (defun kurila-perldoc-at-point () "Run a `perldoc' on the word around point." (interactive) (kurila-perldoc (kurila-word-at-point)))

(defcustom pod2man-program "pod2man" "*File name for `pod2man'." :type 'file :group 'kurila)

;;; By Nick Roberts <> (with changes) (defun kurila-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 (kurila-pod2man-build-command) pod2man-args)) 'Man-bgproc-sentinel)))))

;;; Updated version by him too (defun kurila-build-manpage () "Create a virtual manpage in Emacs from the POD in the file." (interactive) (require 'man) (cond (kurila-xemacs-p (let ((Manual-program "perldoc")) (manual-entry buffer-file-name))) (t (let* ((manual-program "perldoc")) (Man-getpage-in-background buffer-file-name)))))

(defun kurila-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 kurila-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 "") (kurila-next-interpolated-REx 1))

(defun kurila-next-interpolated-REx-0 () "Move point to next REx which has interpolated parts without //o." (interactive "") (kurila-next-interpolated-REx 0))

(defun kurila-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))) (kurila-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 kurila-here-doc-spell (&optional beg end) "Spell-check HERE-documents in the Perl buffer. If a region is highlighted, restricts to the region." (interactive "") (kurila-pod-spell t beg end))

(defun kurila-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 (kurila-mark-active) (setq beg (min (mark) (point)) end (max (mark) (point))) (setq beg (point-min) end (point-max))) (kurila-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 kurila-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))) (kurila-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 kurila-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))) (kurila-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 (kurila-beginning-of-property pos 'syntax-type)) (e (next-single-property-change pos 'syntax-type))) (cons b (or e (point-max))))))

(defun kurila-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 (kurila-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 kurila-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 (kurila-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 kurila-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 kurila-mode" face))))

(defun kurila-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) (kurila-mode) (setq tot (- (- tt (setq tt (funcall timems))))) (message "kurila-mode at %s: %s" l tot) (while (and (< c lim) (not (eobp))) (forward-line step) (setq l (+ l step)) (setq c (1+ c)) (kurila-update-syntaxification (point) (point)) (setq delta (- (- tt (setq tt (funcall timems)))) tot (+ tot delta)) (message "to %s:%6s,%7s" l delta tot)) tot))

(defun kurila-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 Kurila-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 kurila-lazy-install ()) ; Avoid a warning (defun kurila-lazy-unstall ()) ; Avoid a warning

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

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

      (defun kurila-lazy-install ()
        "Switches on Auto-Help on Perl constructs (put in the message area).
Delay of auto-help controlled by `kurila-lazy-help-time'."
        (make-variable-buffer-local 'kurila-help-shown)
        (if (and (kurila-val 'kurila-lazy-help-time)
                 (not kurila-lazy-installed))
              (add-hook 'post-command-hook 'kurila-lazy-hook)
               (kurila-val 'kurila-lazy-help-time 1000000 5)
              (setq kurila-lazy-installed t))))

      (defun kurila-lazy-unstall ()
        "Switches off Auto-Help on Perl constructs (put in the message area).
Delay of auto-help controlled by `kurila-lazy-help-time'."
        (remove-hook 'post-command-hook 'kurila-lazy-hook)
        (cancel-function-timers 'kurila-get-help-defer)
        (setq kurila-lazy-installed nil))

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

      (defun kurila-get-help-defer ()
        (if (not (memq major-mode '(perl-mode kurila-mode))) nil
          (let ((kurila-message-on-help-error nil) (kurila-help-from-timer t))
            (setq kurila-help-shown t))))

;;; Plug for wrong font-lock:

(defun kurila-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 kurila-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 `kurila-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 (kurila-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 kurila-d-l nil) (defun kurila-fontify-syntaxically (end) ;; Some vars for debugging only ;; (message "Syntaxifying...") (let ((dbg (point)) (iend end) (idone kurila-syntax-done-to) (istate (car kurila-syntax-state)) start from-start edebug-backtrace-buffer) (if (eq kurila-syntaxify-by-font-lock 'backtrace) (progn (require 'edebug) (let ((f 'edebug-backtrace)) (funcall f)))) ; Avoid compile-time warning (or kurila-syntax-done-to (setq kurila-syntax-done-to (point-min) from-start t)) (setq start (if (and kurila-hook-after-change (not from-start)) kurila-syntax-done-to ; Fontify without change; ignore start ;; Need to forget what is after `start' (min kurila-syntax-done-to (point)))) (goto-char start) (beginning-of-line) (setq start (point)) (and kurila-syntaxify-unwind (setq end (kurila-unwind-to-safe t end) start (point))) (and (> end start) (setq kurila-syntax-done-to start) ; In case what follows fails (kurila-find-pods-heres start end t nil t)) (if (memq kurila-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 kurila-syntax-done-to istate (car kurila-syntax-state))) ; For debugging nil)) ; Do not iterate

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

(defun kurila-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 'kurila-postpone)) posend) (if prop (setq pos (or (kurila-beginning-of-property (kurila-1+ pos) 'kurila-postpone) (point-min)))) (while (< pos end) (setq posend (next-single-property-change pos 'kurila-postpone)) (and prop (put-text-property pos posend (car prop) (cdr prop))) (setq pos posend) (setq prop (get-text-property pos 'kurila-postpone)))) nil) ; Do not iterate

;; Called when any modification is made to buffer text. (defun kurila-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 kurila-syntax-done-to (setq kurila-syntax-done-to (min kurila-syntax-done-to beg))))

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

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

(provide 'kurila-mode)

;;; kurila-mode.el ends here

syntax highlighting: