1 ;;; Sepia -- Simple Emacs-Perl InterAction: ugly, yet effective.
2 ;; (a.k.a. Septik -- Sean's Emacs-Perl Total Integration Kludge.)
4 ;; Author: Sean O'Rourke <seano@cpan.org>
5 ;; Keywords: Perl, languages
7 ;; Copyright (C) 2004-2010 Sean O'Rourke. All rights reserved, some
8 ;; wrongs reversed. This code is distributed under the same terms
13 ;; Sepia is a set of tools for Perl development in Emacs. Its goal is
14 ;; to extend CPerl mode with two contributions: fast code navigation
15 ;; and interactive development. It is inspired by Emacs' current
16 ;; support for a number of other languages, including Lisp, Python,
17 ;; Ruby, and Emacs Lisp.
19 ;; See sepia.texi, which comes with the distribution.
26 ;; try optional modules, but don't bitch if we fail:
27 (ignore-errors (require 'sepia-w3m
))
28 (ignore-errors (require 'sepia-tree
))
29 (ignore-errors (require 'sepia-ido
))
30 (ignore-errors (require 'sepia-snippet
))
31 ;; extensions that should always load (autoload later?)
34 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
35 ;;; Comint communication
37 (defvar sepia-perl5lib nil
38 "* List of extra PERL5LIB directories for `sepia-repl'.")
40 (defvar sepia-program-name
"perl"
41 "* Perl program name.")
43 (defvar sepia-view-pod-function
44 (if (featurep 'w3m
) 'sepia-w3m-view-pod
'sepia-perldoc-buffer
)
45 "* Function to view current buffer's documentation.
47 Useful values include `sepia-w3m-view-pod' and `sepia-perldoc-buffer'.")
49 (defvar sepia-module-list-function
50 (if (featurep 'w3m
) 'w3m-find-file
'browse-url-of-file
)
51 "* Function to view a list of installed modules.
53 Useful values include `w3m-find-file' and `browse-url-of-buffer'.")
55 (defvar sepia-complete-methods t
56 "* Non-nil if Sepia should try to complete methods for \"$x->\".
58 NOTE: this feature can be problematic, since it evaluates the
59 object in order to find its type. Currently completion is only
60 attempted for objects that are simple scalars.")
62 (defvar sepia-indent-expand-abbrev t
63 "* If non-NIL, `sepia-indent-or-complete' tries `expand-abbrev'.")
65 (defvar sepia-use-completion t
66 "* Use completion based on Xref database.
68 Turning this off may speed up some operations, if you don't mind
71 (defvar sepia-eval-defun-include-decls t
72 "* Generate and use a declaration list for `sepia-eval-defun'.
73 Without this, code often will not parse; with it, evaluation may
74 be a bit less responsive. Note that since this only includes
75 subs from the evaluation package, it may not always work.")
77 (defvar sepia-prefix-key
"\M-."
78 "* Prefix for functions in `sepia-keymap'.")
80 ;;; User options end here.
82 (defvar sepia-process nil
83 "The perl process with which we're interacting.")
84 (defvar sepia-output nil
85 "Current perl output for a response to `sepia-eval-raw', appended
86 to by `perl-collect-output'.")
87 (defvar sepia-passive-output
""
88 "Current perl output for miscellaneous user interaction, used to
89 look for \";;;###\" lisp evaluation markers.")
91 (defvar sepia-perl-builtins nil
92 "List of Perl builtins for completion.")
94 (defun sepia-collect-output (string)
95 "Collect perl output for `sepia-eval-raw' into sepia-output."
96 (setq sepia-output
(concat sepia-output string
))
99 (defun sepia-eval-raw (str)
100 "Evaluate perl code STR, returning a pair (RESULT-STRING . OUTPUT)."
101 (sepia-ensure-process)
104 (let ((sepia-output "")
106 (with-current-buffer (process-buffer sepia-process
)
107 (setq ocpof comint-preoutput-filter-functions
108 comint-preoutput-filter-functions
109 '(sepia-collect-output)))
110 (setq str
(concat "local $Sepia::STOPDIE=0;"
111 "local $Sepia::STOPWARN=0;"
112 "{ package " (sepia-buffer-package) ";"
114 (comint-send-string sepia-process
115 (concat (format "<<%d\n" (length str
)) str
))
116 (while (not (and sepia-output
117 (string-match "> $" sepia-output
)))
118 (accept-process-output sepia-process
))
119 (if (string-match "^;;;[0-9]+\n" sepia-output
)
121 (let* ((x (read-from-string sepia-output
122 (+ (match-beginning 0) 3)))
125 (prog1 (substring sepia-output
(1+ pos
) (+ len pos
1))
126 (setq start
(+ pos len
1))))
127 (and (string-match ";;;[0-9]+\n" sepia-output start
)
128 (let* ((x (read-from-string
130 (+ (match-beginning 0) 3)))
133 (substring sepia-output
(1+ pos
) (+ len pos
1)))))
134 (cons sepia-output nil
)))
135 (with-current-buffer (process-buffer sepia-process
)
136 (setq comint-preoutput-filter-functions ocpof
)))))
138 (defun sepia-eval (str &optional context detailed
)
139 "Evaluate STR in CONTEXT (void by default), and return its result
140 as a Lisp object. If DETAILED is specified, return a
141 pair (RESULT . OUTPUT)."
142 (let* ((tmp (sepia-eval-raw
145 (concat "Sepia::tolisp([" str
"])"))
147 (concat "Sepia::tolisp(scalar(" str
"))"))
148 (t (concat str
";1")))))
151 (setq res
(if context
152 (if (string= res
"") "" (car (read-from-string res
)))
158 (defun sepia-call (fn context
&rest args
)
159 "Call perl function FN in CONTEXT with arguments ARGS, returning
160 its result as a Lisp value."
161 (sepia-eval (concat fn
"(" (mapconcat #'sepia-lisp-to-perl args
", ") ")")
164 (defun sepia-watch-for-eval (string)
165 "Monitor inferior Perl output looking for Lisp evaluation
166 requests. The format for these requests is
167 \"\\n;;;###LENGTH\\nDATA\". Only one such request can come from
168 each inferior Perl prompt."
169 (setq sepia-passive-output
(concat sepia-passive-output string
))
171 ((string-match "^;;;###[0-9]+" sepia-passive-output
)
172 (if (string-match "^;;;###\\([0-9]+\\)\n\\(?:.\\|\n\\)*\n\\(.*> \\)"
173 sepia-passive-output
)
174 (let* ((len (car (read-from-string
175 (match-string 1 sepia-passive-output
))))
176 (pos (1+ (match-end 1)))
177 (res (ignore-errors (eval (car (read-from-string
178 sepia-passive-output pos
181 (substring sepia-passive-output pos
(+ pos len
)) res
)
182 (goto-char (point-max))
183 (insert (substring sepia-passive-output
(+ 1 pos len
)))
184 (set-marker (process-mark (get-buffer-process (current-buffer)))
186 (setq sepia-passive-output
""))
188 (t (setq sepia-passive-output
"") string
)))
191 (defvar sepia-metapoint-map
192 (let ((map (make-sparse-keymap)))
193 (when (featurep 'ido
)
194 (define-key map
"j" 'sepia-jump-to-symbol
))
195 (dolist (kv '(("c" . sepia-callers
)
196 ("C" . sepia-callees
)
197 ("a" . sepia-apropos
)
198 ("A" . sepia-var-apropos
)
199 ("v" . sepia-var-uses
)
200 ("V" . sepia-var-defs
)
201 ;; ("V" . sepia-var-assigns)
202 ("\M-." . sepia-dwim
)
203 ;; ("\M-." . sepia-location)
204 ("l" . sepia-location
)
206 ("r" . sepia-rebuild
)
207 ("m" . sepia-module-find
)
210 ("d" . sepia-perldoc-this
)
211 ("u" . sepia-describe-object
)))
212 (define-key map
(car kv
) (cdr kv
)))
214 "Keymap for Sepia functions. This is just an example of how you
215 might want to bind your keys, which works best when bound to
218 (defvar sepia-shared-map
219 (let ((map (make-sparse-keymap)))
220 (define-key map sepia-prefix-key sepia-metapoint-map
)
221 (define-key map
"\M-," 'sepia-next
)
222 (define-key map
"\C-\M-x" 'sepia-eval-defun
)
223 (define-key map
"\C-c\C-l" 'sepia-load-file
)
224 (define-key map
"\C-c\C-p" 'sepia-view-pod
) ;was cperl-pod-spell
225 (define-key map
"\C-c\C-d" 'cperl-perldoc
)
226 (define-key map
"\C-c\C-r" 'sepia-repl
)
227 (define-key map
"\C-c\C-s" 'sepia-scratch
)
228 (define-key map
"\C-c\C-e" 'sepia-eval-expression
)
229 (define-key map
"\C-c!" 'sepia-set-cwd
)
230 (define-key map
(kbd "TAB") 'sepia-indent-or-complete
)
232 "Sepia bindings common to all modes.")
235 (defun sepia-perldoc-this (name)
236 "View perldoc for module at point."
237 (interactive (list (sepia-interactive-arg 'module
)))
238 (let ((wc (current-window-configuration))
239 (old-pd (symbol-function 'w3m-about-perldoc
))
240 (old-pdb (symbol-function 'w3m-about-perldoc-buffer
)))
241 (condition-case stuff
242 (flet ((w3m-about-perldoc (&rest args
)
243 (let ((res (apply old-pd args
)))
244 (or res
(error "lose: %s" args
))))
245 (w3m-about-perldoc-buffer (&rest args
)
246 (let ((res (apply old-pdb args
)))
247 (or res
(error "lose: %s" args
)))))
248 (funcall (if (featurep 'w3m
) 'w3m-perldoc
'cperl-perldoc
) name
))
249 (error (set-window-configuration wc
)))))
251 (defun sepia-view-pod ()
252 "View POD for the current buffer."
254 (funcall sepia-view-pod-function
))
256 (defun sepia-module-list ()
257 "List installed modules with links to their documentation.
259 This lists not just top-level packages appearing in packlist
260 files, but all documented modules on the system, organized by
263 (let ((file "/tmp/modlist.html"))
264 ;; (unless (file-exists-p file)
265 (sepia-eval-raw (format "Sepia::html_module_list(\"%s\")" file
))
266 (funcall sepia-module-list-function file
)))
268 (defun sepia-package-list ()
269 "List installed packages with links to their documentation.
271 This lists only top-level packages appearing in packlist files.
272 For modules within packages, see `sepia-module-list'."
274 (let ((file "/tmp/packlist.html"))
275 ;; (unless (file-exists-p file)
276 (sepia-eval-raw (format "Sepia::html_package_list(\"%s\")" file
))
277 (funcall sepia-module-list-function file
)))
279 (defun sepia-perldoc-buffer ()
280 "View current buffer's POD using pod2html and `browse-url'.
282 Interactive users should call `sepia-view-pod'."
283 (let ((buffer (get-buffer-create "*sepia-pod*"))
284 (errs (get-buffer-create "*sepia-pod-errors*"))
285 (inhibit-read-only t
))
286 (with-current-buffer buffer
(erase-buffer))
287 (save-window-excursion
288 (shell-command-on-region (point-min) (point-max) "pod2html"
290 (with-current-buffer buffer
(browse-url-of-buffer))))
292 (defun sepia-perl-name (sym &optional mod
)
293 "Convert a Perl name to a Lisp name."
294 (setq sym
(substitute ?_ ?-
(if (symbolp sym
) (symbol-name sym
) sym
)))
296 (concat mod
"::" sym
)
299 (defun sepia-live-p ()
300 (and (processp sepia-process
)
301 (eq (process-status sepia-process
) 'run
)))
303 (defun sepia-ensure-process (&optional remote-host
)
304 (unless (sepia-live-p)
305 (with-current-buffer (get-buffer-create "*sepia-repl*")
307 (set (make-local-variable 'sepia-passive-output
) ""))
309 (comint-exec (get-buffer-create "*sepia-repl*")
310 "attachtty" "attachtty" nil
312 (let ((stuff (split-string sepia-program-name nil t
)))
313 (comint-exec (get-buffer-create "*sepia-repl*")
314 "perl" (car stuff
) nil
317 (mapcar (lambda (x) (concat "-I" x
)) sepia-perl5lib
)
318 '("-MSepia" "-MSepia::Xref"
319 "-e" "Sepia::repl")))))
320 (setq sepia-process
(get-buffer-process "*sepia-repl*"))
321 (accept-process-output sepia-process
1)
322 ;; Steal a bit from gud-common-init:
324 (setq gud-last-last-frame nil
)
325 (set-process-filter sepia-process
'gud-filter
)
326 (set-process-sentinel sepia-process
'gud-sentinel
)))
329 (defun sepia-repl (&optional remote-host
)
330 "Start the Sepia REPL."
331 (interactive (list (and current-prefix-arg
332 (read-string "Host: "))))
333 (sepia-init) ;; set up keymaps, etc.
334 (sepia-ensure-process remote-host
)
335 (pop-to-buffer (get-buffer "*sepia-repl*")))
337 (defun sepia-cont-or-restart ()
339 (if (get-buffer-process (current-buffer))
340 (gud-cont current-prefix-arg
)
343 (defvar sepia-repl-mode-map
344 (let ((map (copy-keymap sepia-shared-map
)))
345 (set-keymap-parent map gud-mode-map
)
346 (define-key map
(kbd "<tab>") 'comint-dynamic-complete
)
347 (define-key map
"\C-a" 'comint-bol
)
348 (define-key map
"\C-c\C-r" 'sepia-cont-or-restart
)
351 "Keymap for Sepia interactive mode.")
353 (define-derived-mode sepia-repl-mode gud-mode
"Sepia REPL"
354 "Major mode for the Sepia REPL.
356 \\{sepia-repl-mode-map}"
357 ;; (set (make-local-variable 'comint-use-prompt-regexp) t)
358 (modify-syntax-entry ?
: "_")
359 (modify-syntax-entry ?
> ".")
360 (set (make-local-variable 'comint-prompt-regexp
) "^[^>\n]*> *")
361 (set (make-local-variable 'gud-target-name
) "sepia")
362 (set (make-local-variable 'gud-marker-filter
) 'sepia-gud-marker-filter
)
363 (set (make-local-variable 'gud-minor-mode
) 'sepia
)
364 (sepia-install-eldoc)
366 (setq gud-comint-buffer
(current-buffer))
367 (setq gud-last-last-frame nil
)
368 (setq gud-sepia-acc nil
)
370 (gud-def gud-break
",break %f:%l" "\C-b" "Set breakpoint at current line.")
371 (gud-def gud-step
",step %p" "\C-s" "Step one line.")
372 (gud-def gud-next
",next %p" "\C-n" "Step one line, skipping calls.")
373 (gud-def gud-cont
",continue" "\C-r" "Continue.")
374 (gud-def gud-print
"%e" "\C-p" "Evaluate something.")
375 (gud-def gud-remove
",delete %l %f" "\C-d" "Delete current breakpoint.")
376 ;; Sadly, this hoses our keybindings.
377 (compilation-shell-minor-mode 1)
378 (set (make-local-variable 'comint-dynamic-complete-functions
)
379 '(sepia-complete-symbol comint-dynamic-complete-filename
))
380 (set (make-local-variable 'comint-preoutput-filter-functions
)
381 '(sepia-watch-for-eval))
382 (run-hooks 'sepia-repl-mode-hook
)
385 (defvar gud-sepia-acc nil
386 "Accumulator for `sepia-gud-marker-filter'.")
388 (defun sepia-gud-marker-filter (str)
391 (concat gud-sepia-acc str
)
393 (while (string-match "_<\\([^:>]+\\):\\([0-9]+\\)>\\(.*\\)" gud-sepia-acc
)
394 (setq gud-last-last-frame gud-last-frame
396 (match-string 1 gud-sepia-acc
)
397 (string-to-number (match-string 2 gud-sepia-acc
)))
398 gud-sepia-acc
(match-string 3 gud-sepia-acc
)))
400 (if (string-match "\\(_<.*\\)" gud-sepia-acc
)
401 (match-string 1 gud-sepia-acc
)
405 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
408 (defun define-xref-function (package name doc
)
409 "Define a lisp mirror for a low-level Sepia function."
410 (let ((lisp-name (intern (format "xref-%s" name
)))
411 (pl-name (sepia-perl-name name package
)))
412 (fmakunbound lisp-name
)
413 (eval `(defun ,lisp-name
(&rest args
)
415 (apply #'sepia-call
,pl-name
'list-context args
)))))
417 (defun define-modinfo-function (name &optional doc context
)
418 "Define a lisp mirror for a function from Module::Info."
419 (let ((name (intern (format "sepia-module-%s" name
)))
420 (pl-func (sepia-perl-name name
))
421 (full-doc (concat (or doc
"") "
423 This function uses Module::Info, so it does not require that the
424 module in question be loaded.")))
425 (when (fboundp name
) (fmakunbound name
))
426 (eval `(defun ,name
(mod)
428 (interactive (list (sepia-interactive-arg 'module
)))
430 (sepia-call "Sepia::module_info" ',(or context
'scalar-context
)
434 (defun sepia-thing-at-point (what)
435 "Like `thing-at-point', but hacked to avoid REPL prompt."
436 (let ((th (thing-at-point what
)))
437 (and th
(not (string-match "[ >]$" th
)) th
)))
439 (defvar sepia-sub-re
"^ *sub\\s +\\(.+\\_>\\)")
441 (defvar sepia-history nil
)
443 (defun sepia-interactive-arg (&optional sepia-arg-type
)
444 "Default argument for most Sepia functions. TYPE is a symbol --
445 either 'file to look for a file, or anything else to use the
447 (let* ((default (case sepia-arg-type
448 (file (or (thing-at-point 'file
) (buffer-file-name)))
449 (t (sepia-thing-at-point 'symbol
))))
450 (text (capitalize (symbol-name sepia-arg-type
)))
452 (lambda (str &rest blah
)
453 (let ((completions (xref-completions
456 (variable "VARIABLE")
460 (when (eq sepia-arg-type
'module
)
462 (remove-if (lambda (x) (string-match "::$" x
)) completions
)))
465 (format "%s [%s]: " text default
)
466 (format "%s: " text
)))
467 (ret (if sepia-use-completion
468 (completing-read prompt
'blah-choices nil nil nil
'sepia-history
470 (read-string prompt nil
'sepia-history default
))))
471 (push ret sepia-history
)
474 (defun sepia-interactive-module ()
475 "Guess which module we should look things up in. Prompting for a
476 module all the time is a PITA, but I don't think this (choosing
477 the current file's module) is a good alternative, either. Best
478 would be to choose the module based on what we know about the
480 (let ((xs (xref-file-modules (buffer-file-name))))
481 (if (= (length xs
) 1)
485 (defun sepia-maybe-echo (result &optional print-message
)
487 (message "%s" result
))
490 (defun sepia-find-module-file (mod)
491 (or (sepia-module-file mod
)
492 (car (xref-guess-module-file mod
))))
494 (defun sepia-module-find (mod)
495 "Find the file defining module MOD."
496 (interactive (list (sepia-interactive-arg 'module
)))
497 (let ((fn (sepia-find-module-file mod
)))
500 (message "Module %s in %s." mod fn
)
501 (pop-to-buffer (find-file-noselect (expand-file-name fn
))))
502 (message "Can't find module %s." mod
))))
504 (defmacro ifa
(test then
&rest else
)
506 (if it
,then
,@else
)))
508 (defvar sepia-found-refiner
)
510 (defun sepia-show-locations (locs)
512 (pop-to-buffer (get-buffer-create "*sepia-places*"))
513 (let ((inhibit-read-only t
))
515 (dolist (loc (sort (remove nil locs
) ; XXX where's nil from?
517 (or (string< (car a
) (car b
))
518 (and (string= (car a
) (car b
))
519 (< (second a
) (second b
)))))))
520 (destructuring-bind (file line name
&rest blah
) loc
521 (let ((str (ifa (find-buffer-visiting file
)
522 (with-current-buffer it
523 (ifa sepia-found-refiner
524 (funcall it line name
)
526 (message "line for %s was %d, now %d" name line
527 (line-number-at-pos))
528 (setq line
(line-number-at-pos))
530 (buffer-substring (sepia-bol-from (point))
531 (sepia-eol-from (point)))))
532 (if (> (length tmpstr
) 60)
533 (concat "\n " tmpstr
)
536 (insert (format "%s:%d:%s\n" (abbreviate-file-name file
) line str
)))))
538 (goto-char (point-min)))))
540 (defmacro define-sepia-query
(name doc
&optional gen test prompt
)
541 "Define a sepia querying function."
542 `(defun ,name
(ident &optional module file line display-p
)
545 With prefix arg, list occurences in a `grep-mode' buffer.
546 Without, place the occurrences on `sepia-found', so that
547 calling `sepia-next' will cycle through them.
549 Depending on the query, MODULE, FILE, and LINE may be used to
550 narrow the results, as long as doing so leaves some matches.
551 When called interactively, they are taken from the current
554 (interactive (list (sepia-interactive-arg ,(or prompt
''function
))
555 (sepia-interactive-module)
557 (line-number-at-pos (point))
562 `(let ((tmp (,gen ident module file line
)))
563 (or (mapcan #',test tmp
) tmp
))
564 `(,gen ident module file line
))))
565 ;; Always clear out the last found ring, because it's confusing
567 (sepia-set-found nil
,(or prompt
''function
))
569 (sepia-show-locations ret
)
570 (sepia-set-found ret
,(or prompt
''function
))
573 (define-sepia-query sepia-defs
574 "Find all definitions of sub."
578 (define-sepia-query sepia-callers
579 "Find callers of FUNC."
583 (define-sepia-query sepia-callees
584 "Find a sub's callees."
588 (define-sepia-query sepia-var-defs
589 "Find a var's definitions."
591 (lambda (x) (setf (third x
) ident
) (list x
))
594 (define-sepia-query sepia-var-uses
597 (lambda (x) (setf (third x
) ident
) (list x
))
600 (define-sepia-query sepia-var-assigns
601 "Find/list assignments to a variable."
603 (lambda (x) (setf (third x
) ident
) (list x
))
606 (defalias 'sepia-package-defs
'sepia-module-describe
)
608 (define-sepia-query sepia-apropos
609 "Find/list subroutines matching regexp."
610 (lambda (name &rest blah
) (xref-apropos name
1))
614 (define-sepia-query sepia-var-apropos
615 "Find/list variables matching regexp."
620 (defun sepia-location (name &optional jump-to
)
621 "Find the definition of NAME.
623 When called interactively (or with JUMP-TO true), go directly
625 (interactive (list (sepia-interactive-arg 'function
) t
))
626 (let* ((fl (or (car (xref-location name
))
627 (car (remove-if #'null
628 (apply #'xref-location
(xref-apropos name
)))))))
629 (when (and (car fl
) (string-match "^(eval " (car fl
)))
630 (message "Can't find definition of %s in %s." name
(car fl
))
634 (sepia-set-found (list fl
) 'function
)
636 (message "No definition for %s." name
))
640 (defun sepia-dwim (&optional display-p
)
641 "Try to do the right thing with identifier at point.
642 * Find all definitions, if thing-at-point is a function
643 * Find all uses, if thing-at-point is a variable
644 * Find documentation, if thing-at-point is a module
648 (multiple-value-bind (type obj
) (sepia-ident-at-point)
649 (sepia-set-found nil type
)
650 (let* ((module-doc-p nil
)
653 ((member type
'(?% ?$ ?
@)) (xref-var-defs obj
))
655 (let (case-fold-search)
656 (string-match "^[^A-Z]" obj
)))
657 (list (sepia-location obj
)))
658 ((sepia-looks-like-module obj
)
659 (setq module-doc-p t
)
660 `((,(sepia-perldoc-this obj
) 1 nil nil
)))
661 (t (setq module-doc-p t
)
662 (call-interactively 'sepia-defs
)))))
665 (sepia-show-locations ret
)
666 (sepia-set-found ret type
)
669 (defun sepia-rebuild ()
670 "Rebuild the Xref database."
674 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
675 ;;; Perl motion commands.
677 ;;; XXX -- these are a hack to prevent infinite recursion calling
678 ;;; e.g. beginning-of-defun from beginning-of-defun-function.
679 ;;; `beginning-of-defun' should handle this.
680 (defmacro sepia-safe-bodf
(&optional n
)
681 `(let ((beginning-of-defun-function
682 (if (and (boundp 'beginning-of-defun-function
)
683 (eq beginning-of-defun-function
'sepia-beginning-of-defun
))
685 beginning-of-defun-function
)))
686 (beginning-of-defun ,n
)))
688 (defmacro sepia-safe-eodf
(&optional n
)
689 `(let ((end-of-defun-function
690 (if (and (boundp 'end-of-defun-function
)
691 (eq end-of-defun-function
'sepia-end-of-defun
))
693 end-of-defun-function
)))
696 (defun sepia-beginning-of-defun (&optional n
)
697 "Move to beginning of current function.
699 The prefix argument is the same as for `beginning-of-defun'."
704 (sepia-end-of-defun (- n
))
706 (re-search-backward sepia-sub-re nil nil n
)))
708 (defun sepia-inside-defun ()
709 "True if point is inside a sub."
713 (re-search-backward sepia-sub-re
)
714 (when (< (point) cur
)
721 (defun sepia-end-of-defun (&optional n
)
722 "Move to end of current function.
724 The prefix argument is the same as for `end-of-defun'."
728 (sepia-beginning-of-defun (- n
))
730 ;; If we're outside a defun, skip to the next
732 (unless (sepia-inside-defun)
733 (re-search-forward sepia-sub-re
)
736 (re-search-backward sepia-sub-re
)
742 (defun sepia-rename-lexical (old new
&optional prompt
)
743 "Replace lexical variable OLD with NEW in the current function.
745 With prefix argument, query for each replacement. It is an error
746 to call this outside a function."
748 (let ((old (sepia-thing-at-point 'symbol
)))
749 (list (read-string "Old name: " old nil old
)
750 (read-string "New name: ")
751 current-prefix-arg
)))
752 (message "(%s %s)" old new
)
753 (unless (sepia-inside-defun)
754 (error "Can't rename %s outside a defun." old
))
755 (setq old
(concat "\\([$%@]\\)\\_<" (regexp-quote old
) "\\_>")
758 (let ((bod (sepia-beginning-of-defun))
759 (eod (sepia-end-of-defun)))
761 (query-replace-regexp old new nil bod eod
)
762 ;; (replace-regexp old new nil bod eod)
764 (while (re-search-forward old eod t
)
765 (replace-match new
)))))
767 (defun sepia-defun-around-point (&optional where
)
768 "Return the text of function around point."
770 (setq where
(point)))
773 (and (sepia-beginning-of-defun)
774 (match-string-no-properties 1))))
776 (defun sepia-lexicals-at-point (&optional where
)
777 "Find lexicals in scope at point."
780 (setq where
(point)))
781 (let ((subname (sepia-defun-around-point where
))
782 (mod (sepia-buffer-package)))
783 (xref-lexicals (sepia-perl-name subname mod
))))
786 (defun sepia-load-file (file &optional rebuild-p collect-warnings
)
787 "Reload a file (interactively, the current buffer's file).
789 With REBUILD-P (or a prefix argument when called interactively),
790 also rebuild the xref database."
791 (interactive (list (expand-file-name (buffer-file-name))
793 (format "*%s errors*" (buffer-file-name))))
795 (when collect-warnings
796 (let (kill-buffer-query-functions)
798 (kill-buffer collect-warnings
))))
799 (let* ((tmp (sepia-eval (format "do '%s' || ($@ && do { local $Sepia::Debug::STOPDIE; die $@ })" file
)
803 (message "sepia: %s returned %s" (abbreviate-file-name file
)
804 (if (equal res
"") "undef" res
))
805 (when (and collect-warnings
807 (with-current-buffer (get-buffer-create collect-warnings
)
808 (let ((inhibit-read-only t
))
809 (delete-region (point-min) (point-max))
811 (sepia-display-errors (point-min) (point-max))
812 (pop-to-buffer (current-buffer))))))
818 (defun sepia-set-found (list &optional type
)
820 (remove-if (lambda (x)
822 (and (not (car x
)) (string= (fourth x
) "main"))))
824 (setq sepia-found
(cons -
1 list
))
825 (setq sepia-found-refiner
(sepia-refiner type
)))
827 (defun sepia-refiner (type)
831 (let ((sub-re (concat "^\\s *sub\\s +.*" ident
"\\_>")))
832 ;; Test this because sometimes we get lucky and get the line
833 ;; just right, in which case beginning-of-defun goes to the
839 (looking-at sub-re
)))
840 (progn (goto-char (point-min))
841 (re-search-forward sub-re nil t
)))
842 (beginning-of-line))))
843 ;; Old version -- this may actually work better if
844 ;; beginning-of-defun goes flaky on us.
845 ;; (or (re-search-backward sub-re
846 ;; (sepia-bol-from (point) -20) t)
847 ;; (re-search-forward sub-re
848 ;; (sepia-bol-from (point) 10) t))
849 ;; (beginning-of-line)
852 (let ((var-re (concat "\\_<" ident
"\\_>")))
854 (line (goto-line line
)
855 (or (re-search-backward var-re
(sepia-bol-from (point) -
5) t
)
856 (re-search-forward var-re
(sepia-bol-from (point) 5) t
)))
857 (t (goto-char (point-min))
858 (re-search-forward var-re nil t
))))))
859 (t (lambda (line ident
) (and line
(goto-line line
))))))
861 (defun sepia-next (&optional arg
)
862 "Go to the next thing (e.g. def, use) found by sepia."
864 (or arg
(setq arg
1))
865 (if (cdr sepia-found
)
866 (let ((i (car sepia-found
))
867 (list (cdr sepia-found
))
868 (len (length (cdr sepia-found
)))
869 (next (+ (car sepia-found
) arg
))
871 (if (and (= len
1) (>= i
0))
872 (message "No more definitions.")
873 ;; if stepwise found next or previous item, it can cycle
874 ;; around the `sepia-found'. When at first or last item, get
884 (setq prompt
"Last one! ")
886 (setq prompt
"First one! "))))
887 ;; if we skip several item, when arrive the first or last
888 ;; item, we will stop at the one. But if we already at last
889 ;; item, then keep going
892 (setq i
(mod next len
))
894 prompt
"First one!"))
897 (setq i
(mod next len
))
899 prompt
"Last one!")))))
900 (setcar sepia-found i
)
901 (setq next
(nth i list
))
902 (let ((file (car next
))
907 (setq file
(and mod
(sepia-find-module-file mod
)))
910 (error "No file for %s." (car next
))))
911 (message "%s at %s:%s. %s" short file line prompt
)
912 (when (file-exists-p file
)
913 (find-file (or file
(sepia-find-module-file mod
)))
914 (when sepia-found-refiner
915 (funcall sepia-found-refiner line short
))
918 (message "No more definitions.")))
920 (defun sepia-previous (&optional arg
)
922 (or arg
(setq arg
1))
923 (sepia-next (- arg
)))
925 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
928 (defun sepia-ident-before-point ()
929 "Find the Perl identifier at or preceding point."
931 (skip-syntax-backward " ")
933 (sepia-ident-at-point)))
935 (defun sepia-simple-method-before-point ()
936 "Find the \"simple\" method call before point.
938 Looks for a simple method called on a variable before point and
939 returns the list (OBJECT METHOD). For example, \"$x->blah\"
940 returns '(\"$x\" \"blah\"). Only simple methods are recognized,
941 because completing anything evaluates it, so completing complex
942 expressions would lead to disaster."
943 (when sepia-complete-methods
945 (bound (max (- (point) 100) (point-min)))
948 ;; XXX - can't do this because COMINT's syntax table is weird.
949 ;; (skip-syntax-backward "_w")
950 (skip-chars-backward "a-zA-Z0-9_")
951 (when (looking-back "->\\s *" bound
)
952 (setq arrow
(search-backward "->" bound
))
953 (skip-chars-backward "a-zA-Z0-9_:")
956 ((char-equal (char-before (point)) ?$
)
957 (setq beg
(1- (point))))
959 ((multiple-value-bind (type obj
) (sepia-ident-at-point)
961 (sepia-looks-like-module obj
)))
964 (list (buffer-substring-no-properties beg arrow
)
965 (buffer-substring-no-properties (+ 2 arrow
) end
)
966 (buffer-substring-no-properties beg end
))))))))
968 (defun sepia-ident-at-point ()
969 "Find the Perl identifier at point."
971 (let ((orig (point)))
972 (when (looking-at "[%$@*&]")
975 (when (re-search-backward "[^A-Za-z_0-9:]" nil
'mu
)
978 (sigil (if (= beg
(point-min))
980 (char-before (point))))
982 (when (re-search-forward "[^A-Za-z_0-9:]" nil
'mu
)
986 ;; try special variables
987 (if (and (member (char-before orig
) '(?$ ?
@ ?%
))
988 (member (car (syntax-after orig
)) '(1 4 5 7 9)))
989 (list (char-before orig
)
990 (buffer-substring-no-properties orig
(1+ orig
)))
993 (list (when (member sigil
'(?$ ?
@ ?% ?
* ?
&)) sigil
)
994 (buffer-substring-no-properties beg end
)))))))
996 (defun sepia-function-at-point ()
997 "Find the Perl function called at point."
1002 (sepia-beginning-of-defun)
1005 (sepia-end-of-defun)
1006 (when (and (>= pt bof
) (< pt
(point)))
1007 (sepia-beginning-of-defun)
1008 (when (and (= (point) bof
) (looking-at "\\s *sub\\s +"))
1009 (forward-char (length (match-string 0)))
1010 (concat (or (sepia-buffer-package) "")
1012 (cadr (sepia-ident-at-point)))))))
1015 (defun sepia-repl-complete ()
1016 "Try to complete the word at point in the REPL.
1017 Just like `sepia-complete-symbol', except that it also completes
1022 (defvar sepia-shortcuts
1024 "break" "eval" "lsbreak" "quit" "size" "wantarray"
1025 "cd" "format" "methods" "reload" "strict" "who"
1026 "debug" "freload" "package" "restart" "test"
1027 "define" "help" "pdl" "save" "time"
1028 "delete" "load" "pwd" "shell" "undef"
1030 "List of currently-defined REPL shortcuts.
1032 XXX: this needs to be updated whenever you add one on the Perl side.")
1034 (defun sepia-complete-symbol ()
1035 "Try to complete the word at point.
1036 The word may be either a global or lexical variable if it has a
1037 sigil, a module, or a function. The function currently ignores
1038 module qualifiers, which may be annoying in larger programs.
1040 The function is intended to be bound to \\M-TAB, like
1041 `lisp-complete-symbol'."
1043 (let ((win (get-buffer-window "*Completions*" 0))
1048 (if (and (eq last-command this-command
)
1049 win
(window-live-p win
) (window-buffer win
)
1050 (buffer-name (window-buffer win
)))
1052 ;; If this command was repeated, and
1053 ;; there's a fresh completion window with a live buffer,
1054 ;; and this command is repeated, scroll that window.
1055 (with-current-buffer (window-buffer win
)
1056 (if (pos-visible-in-window-p (point-max) win
)
1057 (set-window-start win
(point-min))
1058 (save-selected-window
1062 ;; Otherwise actually do completion:
1063 ;; 0 - try a shortcut
1064 (when (eq major-mode
'sepia-repl-mode
)
1067 (when (looking-at ",\\([a-z]+\\)$")
1068 (let ((str (match-string 1)))
1069 (setq len
(length str
)
1070 completions
(all-completions str sepia-shortcuts
))))))
1071 ;; 1 - Look for a method call:
1073 (setq meth
(sepia-simple-method-before-point))
1075 (setq len
(length (caddr meth
))
1076 completions
(xref-method-completions
1077 (cons 'expr
(format "'%s'" (car meth
)))
1080 type
(format "%s->" (car meth
)))))
1081 ;; 1.x - look for a module
1084 (and (looking-back " *\\(?:use\\|require\\|package\\|no\\)\\s +[^ ]*" (sepia-bol-from (point)))
1085 (xref-apropos-module
1086 (multiple-value-bind (typ name
)
1087 (sepia-ident-before-point)
1088 (setq len
(length name
))
1092 (multiple-value-bind (typ name
) (sepia-ident-before-point)
1094 ;; 2 - look for a regular function/variable/whatever
1096 len
(+ (if type
1 0) (length name
))
1102 (format "%c%s" type x
)))
1112 (and (eq major-mode
'sepia-mode
)
1113 (sepia-function-at-point))))))
1114 ;; 3 - try a Perl built-in
1115 (when (and (not completions
)
1116 (or (not type
) (eq type ?
&)))
1117 (when (string-match ".*::([^:]+)$" name
)
1118 (setq name
(match-string 1 name
)))
1119 (setq completions
(all-completions name sepia-perl-builtins
)))
1120 (case (length completions
)
1121 (0 (message "No completions.") nil
)
1122 (1 ;; XXX - skip sigil to match s-i-before-point
1123 (delete-region (- (point) len
) (point))
1124 (insert (car completions
))
1125 ;; Hide stale completions buffer (stolen from lisp.el).
1126 (if win
(with-selected-window win
(bury-buffer))) t
)
1128 (new (try-completion "" completions
)))
1129 (if (<= (length new
) (+ (length old
) (if type
1 0)))
1130 (with-output-to-temp-buffer "*Completions*"
1131 (display-completion-list completions
))
1132 (let ((win (get-buffer-window "*Completions*" 0)))
1133 (if win
(with-selected-window win
(bury-buffer))))
1134 (delete-region (- (point) len
) (point))
1138 (defun sepia-indent-or-complete ()
1139 "Indent the current line or complete the symbol around point.
1141 Specifically, try completion when indentation doesn't move point.
1142 This function is intended to be bound to TAB."
1144 (let ((pos (point)))
1145 (let (beginning-of-defun-function
1146 end-of-defun-function
)
1147 (cperl-indent-command))
1148 (when (and (= pos
(point))
1150 (or (eq last-command
'sepia-indent-or-complete
)
1151 (looking-at "\\_>")))
1152 (when (or (not sepia-indent-expand-abbrev
)
1153 (and (not (expand-abbrev))
1154 ;; XXX this shouldn't be necessary, but
1155 ;; expand-abbrev returns NIL for e.g. the "else"
1158 (sepia-complete-symbol)))))
1160 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1163 (defvar sepia-mode-map
1164 (let ((map (copy-keymap sepia-shared-map
)))
1165 (set-keymap-parent map cperl-mode-map
)
1166 (define-key map
"\C-c\C-h" nil
)
1168 "Keymap for Sepia mode.")
1171 (define-derived-mode sepia-mode cperl-mode
"Sepia"
1172 "Major mode for Perl editing, derived from cperl mode.
1175 (sepia-install-eldoc)
1177 (set (make-local-variable 'beginning-of-defun-function
)
1178 'sepia-beginning-of-defun
)
1179 (set (make-local-variable 'end-of-defun-function
)
1180 'sepia-end-of-defun
)
1181 (setq indent-line-function
'sepia-indent-line
))
1183 (defun sepia-init ()
1184 "Perform the initialization necessary to start Sepia."
1186 ;; Create glue wrappers for Module::Info funcs.
1187 (unless (fboundp 'xref-completions
)
1188 (dolist (x '((name "Find module name.\n\nDoes not require loading.")
1189 (version "Find module version.\n\nDoes not require loading.")
1190 (inc-dir "Find directory in which this module was found.\n\nDoes not require loading.")
1191 (file "Absolute path of file defining this module.\n\nDoes not require loading.")
1192 (is-core "Guess whether or not a module is part of the core distribution.
1193 Does not require loading.")
1194 (modules-used "List modules used by this module.\n\nRequires loading." list-context
)
1195 (packages-inside "List sub-packages in this module.\n\nRequires loading." list-context
)
1196 (superclasses "List module's superclasses.\n\nRequires loading." list-context
)))
1197 (apply #'define-modinfo-function x
))
1198 ;; Create low-level wrappers for Sepia
1199 (dolist (x '((completions "Find completions in the symbol table.")
1200 (method-completions "Complete on an object's methods.")
1201 (location "Find an identifier's location.")
1202 (mod-subs "Find all subs defined in a package.")
1203 (mod-decls "Generate declarations for subs in a package.")
1204 (mod-file "Find the file defining a package.")
1205 (apropos "Find subnames matching RE.")
1206 (lexicals "Find lexicals for a sub.")
1207 (apropos-module "Find installed modules matching RE.")
1209 (apply #'define-xref-function
"Sepia" x
))
1211 (dolist (x '((rebuild "Build Xref database for current Perl process.")
1212 (redefined "Rebuild Xref information for a given sub.")
1214 (callers "Find all callers of a function.")
1215 (callees "Find all functions called by a function.")
1217 (var-apropos "Find varnames matching RE.")
1218 (mod-apropos "Find modules matching RE.")
1219 (file-apropos "Find files matching RE.")
1221 (var-defs "Find all definitions of a variable.")
1222 (var-assigns "Find all assignments to a variable.")
1223 (var-uses "Find all uses of a variable.")
1225 (mod-redefined "Rebuild Xref information for a given package.")
1226 (guess-module-file "Guess file corresponding to module.")
1227 (file-modules "List the modules defined in a file.")))
1228 (apply #'define-xref-function
"Sepia::Xref" x
))
1229 ;; Initialize built hash
1230 (sepia-init-perl-builtins)))
1232 (defvar sepia-scratchpad-mode-map
1233 (let ((map (make-sparse-keymap)))
1234 (set-keymap-parent map sepia-mode-map
)
1235 (define-key map
"\C-j" 'sepia-scratch-send-line
)
1239 (define-derived-mode sepia-scratchpad-mode sepia-mode
"Sepia-Scratch"
1240 "Major mode for the Perl scratchpad, derived from Sepia mode."
1244 (defun sepia-scratch ()
1245 "Switch to the sepia scratchpad."
1248 (or (get-buffer "*sepia-scratch*")
1249 (with-current-buffer (get-buffer-create "*sepia-scratch*")
1250 (sepia-scratchpad-mode)
1251 (current-buffer)))))
1253 (defun sepia-scratch-send-line (&optional scalarp
)
1254 "Send the current line to perl, and display the result."
1260 (concat "$Sepia::REPL{eval}->(q#"
1261 (buffer-substring (sepia-bol-from (point))
1262 (sepia-eol-from (point))) "#)"))))))
1264 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1267 (defun sepia-indent-line (&rest args
)
1268 "Unbind `beginning-of-defun-function' to not confuse `cperl-indent-line'."
1269 (let (beginning-of-defun-function)
1270 (apply #'cperl-indent-line args
)))
1272 (defun sepia-string-count-matches (reg str
)
1275 (while (setq pos
(string-match reg str
(1+ pos
)))
1279 (defun sepia-perlize-region-internal (pre post beg end replace-p
)
1280 "Pass buffer text from BEG to END through a Perl command."
1281 (let* ((exp (concat pre
"<<'SEPIA_END_REGION';\n"
1282 (buffer-substring-no-properties beg end
)
1283 (if (= (char-before end
) ?
\n) "" "\n")
1284 "SEPIA_END_REGION\n" post
))
1285 (new-str (car (sepia-eval-raw exp
))))
1287 (progn (delete-region beg end
)
1290 (if (> (sepia-string-count-matches "\n" new-str
) 2)
1291 (with-current-buffer (get-buffer-create "*sepia-filter*")
1292 (let ((inhibit-read-only t
))
1295 (goto-char (point-min))
1296 (pop-to-buffer (current-buffer))))
1297 (message "%s" new-str
)))))
1299 (defun sepia-eol-from (pt &optional n
)
1305 (defun sepia-bol-from (pt &optional n
)
1308 (beginning-of-line n
)
1311 (defun sepia-perl-pe-region (expr beg end
&optional replace-p
)
1312 "Do the equivalent of perl -pe on region
1314 \(i.e. evaluate an expression on each line of region). With
1315 prefix arg, replace the region with the result."
1316 (interactive "MExpression: \nr\nP")
1317 (sepia-perlize-region-internal
1318 "do { my $ret=''; local $_; local $/ = \"\\n\"; my $region = "
1319 (concat "; for (split /(?<=\\n)/, $region, -1) { " expr
1320 "} continue { $ret.=$_}; $ret}")
1321 (sepia-bol-from beg
) (sepia-eol-from end
) replace-p
))
1323 (defun sepia-perl-ne-region (expr beg end
&optional replace-p
)
1324 "Do the moral equivalent of perl -ne on region
1326 \(i.e. evaluate an expression on each line of region). With
1327 prefix arg, replace the region with the result."
1328 (interactive "MExpression: \nr\nP")
1329 (sepia-perlize-region-internal
1330 "do { my $ret='';my $region = "
1331 (concat "; for (split /(?<=\\n)/, $region, -1) { $ret .= do { " expr
1333 (sepia-bol-from beg
) (sepia-eol-from end
) replace-p
))
1335 (defun sepia-perlize-region (expr beg end
&optional replace-p
)
1336 "Evaluate a Perl expression on the region as a whole.
1338 With prefix arg, replace the region with the result."
1339 (interactive "MExpression: \nr\nP")
1340 (sepia-perlize-region-internal
1341 "do { local $_ = " (concat "; do { " expr
";}; $_ }") beg end replace-p
))
1343 (defun sepia-core-version (module &optional message
)
1344 "Report the first version of Perl shipping with MODULE."
1345 (interactive (list (sepia-interactive-arg 'module
) t
))
1348 (format "eval { Sepia::core_version('%s') }" module
)
1351 (format "%s was first released in %s." module version
)
1352 (format "%s is not in core." module
))))
1353 (when message
(message "%s" res
))
1356 (defun sepia-guess-package (sub &optional file
)
1357 "Guess which package SUB is defined in."
1358 (let ((defs (xref-location (xref-apropos sub
))))
1359 (or (and (= (length defs
) 1)
1360 (or (not file
) (equal (caar defs
) file
))
1361 (fourth (car defs
)))
1363 (fourth (find-if (lambda (x) (equal (car x
) file
)) defs
)))
1364 ;; (car (xref-file-modules file))
1365 (sepia-buffer-package))))
1368 (defun sepia-apropos-module (name)
1369 "List installed modules matching a regexp."
1370 (interactive "MList modules matching regexp: ")
1371 (let ((res (xref-apropos-module name
)))
1373 (with-output-to-temp-buffer "*Modules*"
1374 (display-completion-list res
))
1375 (message "No modules matching %s." name
))))
1378 (defun sepia-eval-defun ()
1379 "Re-evaluate the current function and rebuild its Xrefs."
1381 (let (pt end beg sub res
1387 end
(progn (end-of-defun) (point))
1388 beg
(progn (beginning-of-defun) (point)))
1390 (when (looking-at "^sub\\s +\\(.+\\_>\\)")
1391 (setq sub
(match-string 1))
1392 (let ((body (buffer-substring-no-properties beg end
)))
1394 (setq sepia-eval-package
(sepia-guess-package sub
(buffer-file-name))
1395 sepia-eval-file
(buffer-file-name)
1396 sepia-eval-line
(line-number-at-pos beg
)
1399 (if sepia-eval-defun-include-decls
1401 (apply #'concat
(xref-mod-decls sepia-eval-package
))
1406 (when (string-match " line \\([0-9]+\\), near \"\\([^\"]*\\)\""
1409 (beginning-of-line (string-to-number (match-string 1 (cdr res
))))
1410 (search-forward (match-string 2 (cdr res
))
1411 (sepia-eol-from (point)) t
))
1412 (message "Error: %s" (cdr res
)))
1413 (xref-redefined sub sepia-eval-package
)
1414 (message "Defined %s" sub
))))
1417 (defun sepia-eval-expression (expr &optional list-p message-p
)
1418 "Evaluate EXPR in scalar context."
1419 (interactive (list (read-string "Expression: ") current-prefix-arg t
))
1420 (let ((res (sepia-eval expr
(if list-p
'list-context
'scalar-context
))))
1421 (when message-p
(message "%s" res
))
1424 (defun sepia-extract-def (file line obj
)
1425 (with-current-buffer (find-file-noselect (expand-file-name file
))
1427 (funcall (sepia-refiner 'function
) line obj
)
1429 (when (looking-at (concat "^\\s *sub\\_>.*\\_<" obj
"\\_>"))
1430 (buffer-substring (point)
1431 (progn (end-of-defun) (point)))))))
1433 (defun sepia-eval-no-run (string)
1434 (let ((res (sepia-eval-raw
1435 (concat "eval q#{ BEGIN { use B; B::minus_c(); $^C=1; } do { "
1437 " };BEGIN { die \"ok\\n\" }#, $@"))))
1438 (if (string-match "^ok\n" (car res
))
1442 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1445 (defvar sepia-eval-file nil
1446 "File in which `sepia-eval' evaluates perl expressions.")
1447 (defvar sepia-eval-line nil
1448 "Line at which `sepia-eval' evaluates perl expressions.")
1450 (defun sepia-set-cwd (dir)
1451 "Set the inferior Perl process's working directory to DIR.
1453 When called interactively, the current buffer's
1454 `default-directory' is used."
1455 (interactive (list (expand-file-name default-directory
)))
1456 (sepia-call "Cwd::chdir" 'list-context dir
))
1458 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1461 (defvar sepia-doc-map
(make-hash-table :test
#'equal
))
1462 (defvar sepia-var-doc-map
(make-hash-table :test
#'equal
))
1463 (defvar sepia-module-doc-map
(make-hash-table :test
#'equal
))
1465 (defun sepia-doc-scan-buffer ()
1467 (goto-char (point-min))
1469 while
(re-search-forward
1470 "^=\\(item\\|head[2-9]\\)\\s +\\([%$&@A-Za-z_].*\\)" nil t
)
1473 (let ((short (match-string 2)) longdoc
)
1475 (let ((case-fold-search nil
))
1476 (replace-regexp-in-string
1478 (replace-regexp-in-string
1480 (replace-regexp-in-string
1481 "[A-DF-Z]<\\([^<>]+\\)>" "\\1" short
)))))
1482 (while (string-match "^\\s *[A-Z]<\\(.*\\)>\\s *$" short
)
1483 (setq short
(match-string 1 short
)))
1485 (let ((beg (progn (forward-line 2) (point)))
1486 (end (1- (re-search-forward "^=" nil t
))))
1489 (if (re-search-forward "^\\(.+\\)$" end t
)
1491 (substring-no-properties
1493 0 (position ?.
(match-string 1))))
1496 ;; e.g. "$x -- this is x"
1497 ((string-match "^[%$@]\\([A-Za-z0-9_:]+\\)\\s *--\\s *\\(.*\\)"
1499 (list 'variable
(match-string-no-properties 1 short
)
1500 (or (and (equal short
(match-string 1 short
)) longdoc
)
1502 ;; e.g. "C<foo(BLAH)>" or "$x = $y->foo()"
1503 ((string-match "\\([A-Za-z0-9_:]+\\)\\s *\\(\\$\\|(\\)" short
)
1504 (list 'function
(match-string-no-properties 1 short
)
1505 (or (and (equal short
(match-string 1 short
)) longdoc
)
1507 ;; e.g. "C<$result = foo $args...>"
1508 ((string-match "=\\s *\\([A-Za-z0-9_:]+\\)" short
)
1509 (list 'function
(match-string-no-properties 1 short
)
1510 (or (and (equal short
(match-string 1 short
)) longdoc
)
1512 ;; e.g. "$x this is x" (note: this has to come last)
1513 ((string-match "^[%$@]\\([^( ]+\\)" short
)
1514 (list 'variable
(match-string-no-properties 1 short
) longdoc
)))))
1517 (defun sepia-buffer-package ()
1519 (or (and (re-search-backward "^\\s *package\\s +\\([^ ;]+\\)\\s *;" nil t
)
1520 (match-string-no-properties 1))
1523 (defun sepia-doc-update ()
1524 "Update documentation for a file.
1526 This documentation, taken from \"=item\" entries in the POD, is
1527 used for eldoc feedback."
1529 (let ((pack (ifa (sepia-buffer-package) (concat it
"::") "")))
1530 (dolist (x (sepia-doc-scan-buffer))
1531 (let ((map (ecase (car x
)
1532 (function sepia-doc-map
)
1533 (variable sepia-var-doc-map
))))
1534 (puthash (second x
) (third x
) map
)
1535 (puthash (concat pack
(second x
)) (third x
) map
)))))
1537 (defun sepia-looks-like-module (obj)
1538 (let (case-fold-search)
1540 (eval-when-compile (regexp-opt '("strict" "vars" "warnings" "lib")))
1543 (string-match "^\\([A-Z][A-Za-z0-9]*::\\)*[A-Z]+[A-Za-z0-9]+\\sw*$" obj
)))))
1545 (defun sepia-describe-object (thing)
1546 "Display documentation for `thing', like ``describe-function'' for elisp."
1548 (let ((id (sepia-ident-at-point)))
1549 (when (string= (cadr id
) "")
1550 (setq id
(sepia-ident-before-point)))
1556 (setq thing
(format "%c%s" (car thing
) (cadr thing
)))
1557 (with-current-buffer (get-buffer-create "*sepia-help*")
1558 (let ((inhibit-read-only t
))
1560 (shell-command (concat "perldoc -v " (shell-quote-argument thing
))
1563 (goto-char (point-min)))
1564 (unless (looking-at "No documentation for")
1565 (pop-to-buffer "*sepia-help*" t
))))
1566 ((gethash thing sepia-perl-builtins
)
1567 (with-current-buffer (get-buffer-create "*sepia-help*")
1568 (let ((inhibit-read-only t
))
1570 (shell-command (concat "perldoc -f " thing
) (current-buffer))
1572 (goto-char (point-min))))
1573 (pop-to-buffer "*sepia-help*" t
))))
1575 (defun sepia-symbol-info (&optional obj type
)
1576 "Eldoc function for `sepia-mode'.
1578 Looks in `sepia-doc-map' and `sepia-var-doc-map', then tries
1579 calling `cperl-describe-perl-symbol'."
1581 (multiple-value-bind (ty ob
) (sepia-ident-at-point)
1582 (setq obj
(if (consp ob
) (car ob
) ob
)
1585 (or (gethash obj
(ecase (or type ?
&)
1587 ((?$ ?
@ ?%
) sepia-var-doc-map
)
1588 (nil sepia-module-doc-map
)
1589 (?
* sepia-module-doc-map
)
1590 (t (error "sepia-symbol-info: %s" type
))))
1591 ;; Loathe cperl a bit.
1592 (flet ((message (&rest blah
) (apply #'format blah
)))
1593 (let* (case-fold-search
1594 (cperl-message-on-help-error nil
)
1595 (hlp (car (save-excursion
1596 (cperl-describe-perl-symbol
1597 (if (member type
'(?$ ?
@ ?%
))
1598 (format "%c%s" type obj
)
1602 ;; cperl's docstrings are too long.
1603 (setq hlp
(replace-regexp-in-string "\\s \\{2,\\}\\|\t" " " hlp
))
1604 (if (> (length hlp
) 75)
1605 (concat (substring hlp
0 72) "...")
1607 ;; Try to see if it's a module
1609 (let ((bol (save-excursion (beginning-of-line)
1611 (looking-back " *\\(?:use\\|require\\|package\\|no\\)\\s +[^ ]*" bol
))
1612 (sepia-looks-like-module obj
))
1613 (sepia-core-version obj
)
1617 (defun sepia-install-eldoc ()
1618 "Install Sepia hooks for eldoc support."
1621 (set-variable 'eldoc-documentation-function
'sepia-symbol-info t
)
1622 (if cperl-lazy-installed
(cperl-lazy-unstall))
1624 (set-variable 'eldoc-idle-delay
1.0 t
))
1626 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1629 (defun sepia-extract-next-warning (pos &optional end
)
1631 (while (re-search-forward "^\\(.+\\) at \\(.+?\\) line \\([0-9]+\\)"
1633 (unless (string= "(eval " (substring (match-string 2) 0 6))
1634 (throw 'foo
(list (match-string 2)
1635 (string-to-number (match-string 3))
1636 (match-string 1)))))))
1638 (defun sepia-goto-error-at (pos)
1639 "Visit the source of the error on line at point."
1641 (ifa (sepia-extract-next-warning (sepia-bol-from pos
) (sepia-eol-from pos
))
1642 (destructuring-bind (file line msg
) it
1646 (error "No error to find.")))
1648 (defun sepia-display-errors (beg end
)
1649 "Display source causing errors in current buffer from BEG to END."
1653 (loop for w
= (sepia-extract-next-warning (sepia-bol-from (point)) end
)
1655 do
(destructuring-bind (file line msg
) w
1656 (push (format "%s:%d:%s\n" (abbreviate-file-name file
) line msg
)
1659 (goto-char (point-min))
1660 (mapc #'insert
(nreverse msgs
))
1661 (goto-char (point-min))
1664 (defun sepia-lisp-to-perl (thing)
1665 "Convert elisp data structure to Perl."
1667 ((null thing
) "undef")
1669 (let ((pname (substitute ?_ ?-
(symbol-name thing
)))
1670 (type (string-to-char (symbol-name thing
))))
1671 (if (member type
'(?% ?$ ?
@ ?
*))
1673 (concat "\\*" pname
))))
1674 ((stringp thing
) (format "%S" (substring-no-properties thing
0)))
1675 ((integerp thing
) (format "%d" thing
))
1676 ((numberp thing
) (format "%g" thing
))
1678 ((and (consp thing
) (eq (car thing
) 'expr
))
1679 (cdr thing
)) ; XXX -- need quoting??
1680 ((and (consp thing
) (not (consp (cdr thing
))))
1681 (concat (sepia-lisp-to-perl (car thing
)) " => "
1682 (sepia-lisp-to-perl (cdr thing
))))
1684 ((or (not (consp (car thing
)))
1685 (listp (cdar thing
)))
1686 (concat "[" (mapconcat #'sepia-lisp-to-perl thing
", ") "]"))
1689 (concat "{" (mapconcat #'sepia-lisp-to-perl thing
", ") "}"))))
1691 (defun sepia-init-perl-builtins ()
1692 (setq sepia-perl-builtins
(make-hash-table :test
#'equal
))
1895 (puthash s t sepia-perl-builtins
)))
1898 ;;; sepia.el ends here