1 ;;; Sepia -- Simple Emacs-Perl InterAction: ugly, yet effective.
2 ;;; (a.k.a. Septik -- Sean's Emacs-Perl Total Integration Kludge.)
4 ;; Copyright (C) 2004 Sean O'Rourke. All rights reserved, some wrongs
5 ;; reversed. This code is distributed under the same terms as Perl
10 ;; See the README file that comes with the distribution.
16 (require 'generic-repl
)
19 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
20 ;;; Xrefs -- use Perl to find definitions and uses.
22 (defvar sepia-use-completion t
23 "* Use completion based on Xref database. Turning this off may
24 speed up some operations, if you don't mind losing completion.")
26 (defvar sepia-eval-defun-include-decls t
27 "* Generate and use a declaration list for ``sepia-eval-defun''.
28 Without this, code often will not parse; with it, evaluation may
29 be a bit less responsive. Note that since this only includes
30 subs from the evaluation package, it may not always work.")
32 (defvar sepia-prefix-key
"\M-."
33 "* Prefix for functions in ``sepia-keymap''.")
35 (defvar sepia-initializer
37 BEGIN { push @INC, \"$ENV{HOME}/src/perl\" };
48 $info = Module::Info->new_from_file($m);
50 (my $file = $m) =~ s|::|/|g;
52 if (exists $INC{$file}) {
53 $info = Module::Info->new_from_loaded($m);
55 $info = Module::Info->new_from_module($m);
67 (let ((km (make-sparse-keymap)))
68 (dolist (kv '(("c" . sepia-callers
)
70 ("v" . sepia-var-uses
)
71 ("V" . sepia-var-defs
)
72 ;; ("V" . sepia-var-assigns)
73 ;; ("\M-." . sepia-dwim)
74 ("\M-." . sepia-location
)
75 ("d" . sepia-w3m-perldoc-this
)
78 ("m" . sepia-module-find
)
80 (define-key km
(car kv
) (cdr kv
)))
82 "Keymap for Sepia functions. This is just an example of how you
83 might want to bind your keys, which works best when bound to
86 (defun sepia-install-keys (&optional map
)
87 "Install Sepia bindings in the current local keymap."
89 (let ((map (or map
(current-local-map))))
90 (define-key map sepia-prefix-key sepia-keymap
)
91 (define-key map
"\M-," 'sepia-next
)
92 (define-key map
"\C-\M-x" 'sepia-eval-defun
)
93 (define-key map
"\C-c\C-l" 'sepia-eval-buffer
)
94 (define-key map
"\C-c\C-d" 'sepia-w3m-view-pod
)))
96 (defun perl-name (sym)
97 (substitute ?_ ?-
(symbol-name sym
)))
101 "Perform the initialization necessary to start Sepia, a set of
102 tools for developing Perl in Emacs.
104 The following keys are bound to the prefix
105 ``sepia-prefix-key'' (`\\M-.' by default), which can be changed
106 by setting ``sepia-prefix'' before calling ``sepia-init'':
110 In addition to these keys, Sepia defines the following keys,
111 which may conflict with keys in your setup, but which are
112 intended to shadow similar functionality in elisp-mode:
114 `\\C-c\\C-d' ``sepia-w3m-view-pod''
115 `\\C-c\\C-l' ``sepia-eval-buffer''
116 `\\C-\\M-x' ``sepia-eval-defun''
117 `\\M-,' ``sepia-next'' (shadows ``tags-loop-continue'')
122 (kill-process "perl")
123 (setq perl-interpreter nil
))
126 (perl-eval sepia-initializer
'void-context
)
128 ;; Create glue wrappers for Module::Info funcs.
129 (dolist (x '((name .
"Find module name. Does not require loading.")
130 (version .
"Find module version. Does not require loading.")
132 "Find directory in which this module was found. Does not require loading.")
134 "Absolute path of file defining this module. Does not require loading.")
136 "Guess whether or not a module is part of the core distribution.
137 Does not require loading.")
139 "List modules used by this module. Requires loading.")
141 "List sub-packages in this module. Requires loading.")
143 "List module's superclasses. Requires loading.")))
144 (define-modinfo-function (car x
) (cdr x
)))
146 ;; Create low-level wrappers for Devel::Xref
147 (dolist (x '((rebuild .
"Build Xref database for current Perl process.")
148 (redefined .
"Rebuild Xref information for a given sub.")
149 (completions .
"Find completions in the symbol table.")
150 (location .
"Find an identifier's location.")
152 (defs .
"Find all definitions of a function.")
153 (callers .
"Find all callers of a function.")
154 (callees .
"Find all functions called by a function.")
156 (apropos .
"Find subnames matching RE.")
157 (var-apropos .
"Find varnames matching RE.")
158 (mod-apropos .
"Find modules matching RE.")
159 (file-apropos .
"Find files matching RE.")
161 (var-defs .
"Find all definitions of a variable.")
162 (var-assigns .
"Find all assignments to a variable.")
163 (var-uses .
"Find all uses of a variable.")
165 (mod-redefined .
"Rebuild Xref information for a given package.")
166 (mod-subs .
"Find all subs defined in a package.")
167 (mod-files .
"Find the file defining a package.")
168 (mod-decls .
"Generate declarations for subs in a package.")
169 (guess-module-file .
"Guess file corresponding to module.")
170 (file-modules .
"List the modules defined in a file.")))
171 (define-xref-function (car x
) (cdr x
)))
172 (add-hook 'cperl-mode-hook
'sepia-install-eldoc
)
173 (add-hook 'cperl-mode-hook
'sepia-doc-update
)
174 (add-hook 'sepia-repl-hook
'sepia-repl-init-syntax
)
175 (add-hook 'sepia-repl-hook
'sepia-install-eldoc
)
176 (if (boundp 'cperl-mode-map
)
177 (sepia-install-keys cperl-mode-map
))
181 (defun define-xref-function (name doc
)
182 "Define a lisp mirror for a function from Devel::Xref."
183 (let ((lisp-name (intern (format "xref-%s" name
)))
184 (pl-name (format "Devel::Xref::%s" (perl-name name
))))
185 (when (fboundp lisp-name
) (fmakunbound lisp-name
))
186 (eval `(defun ,lisp-name
(&rest args
)
188 (apply #'perl-call
,pl-name
'list-context args
)))))
190 (defun define-modinfo-function (name &optional doc
)
191 "Define a lisp mirror for a function from Module::Info."
192 (let ((name (intern (format "sepia-module-%s" name
)))
193 (pl-func (perl-name name
))
194 (full-doc (concat (or doc
"") "
196 This function uses Module::Info, so it does not require that the
197 module in question be loaded.")))
198 (when (fboundp name
) (fmakunbound name
))
199 (eval `(defun ,name
(mod)
201 (interactive (list (sepia-interactive-arg 'module
)))
202 (let ((res (perl-call "_module_info" 'scalar-context
208 (defun sepia-thing-at-point (what)
209 "Like ``thing-at-point'', but hacked to avoid REPL prompt."
210 (let ((th (thing-at-point what
)))
211 (and th
(not (string-match "[ >]$" th
)) th
)))
213 (defun sepia-interactive-arg (&optional type
)
214 "Default argument for most Sepia functions. TYPE is a symbol --
215 either 'file to look for a file, or anything else to use the
217 (let* ((default (case type
218 (file (or (thing-at-point 'file
) (buffer-file-name)))
219 (t (sepia-thing-at-point 'symbol
))))
220 (text (capitalize (symbol-name type
)))
221 (choices (lambda (str &rest blah
)
222 (let ((str (concat "^" str
)))
224 (variable (xref-var-apropos str
))
225 (function (xref-apropos str
))
226 (module (xref-mod-apropos str
))
228 (ret (if sepia-use-completion
229 (completing-read (format "%s [%s]: " text default
)
230 choices nil nil nil
'sepia-history
232 (read-string (format "%s [%s]: " text default
)
233 nil
'sepia-history default
))))
234 (push ret sepia-history
)
237 (defun sepia-interactive-module ()
238 "Guess which module we should look things up in. Prompting for a
239 module all the time is a PITA, but I don't think this (choosing
240 the current file's module) is a good alternative, either. Best
241 would be to choose the module based on what we know about the
243 (let ((xs (xref-file-modules (buffer-file-name))))
244 (if (= (length xs
) 1)
248 (defun sepia-maybe-echo (result)
249 (when (interactive-p)
250 (message "%s" result
))
253 (defun sepia-module-find (mod)
254 "Find the file defining module MOD."
255 (interactive (list (sepia-interactive-arg 'module
)))
256 (let ((fn (or (sepia-module-file mod
)
257 (xref-guess-module-file mod
))))
259 (message "Module %s in %s." mod fn
)
260 (pop-to-buffer (find-file-noselect (expand-file-name fn
))))))
262 (defmacro ifa
(test then
&rest else
)
264 (if it
,then
,@else
)))
266 (defun sepia-show-locations (locs)
268 (pop-to-buffer (get-buffer-create "*sepia-places*"))
270 (dolist (loc (sort locs
(lambda (a b
)
271 (or (string< (car a
) (car b
))
272 (and (string= (car a
) (car b
))
273 (< (second a
) (second b
)))))))
274 (destructuring-bind (file line name
&rest blah
) loc
275 (let ((str (ifa (find-buffer-visiting file
)
276 (with-current-buffer it
277 (ifa sepia-found-refiner
278 (funcall it line name
)
280 (message "line for %s was %d, now %d" name line
281 (line-number-at-pos))
282 (setq line
(line-number-at-pos))
284 (buffer-substring (my-bol-from (point))
285 (my-eol-from (point)))))
287 (insert (format "%s:%d:%s\n" (abbreviate-file-name file
) line str
)))))
289 (goto-char (point-min))))
291 (defun sepia-filter-by-module (x)
292 "Filter to limit hits by module only."
293 (when (or (not module
) (string= module
(fourth x
)))
296 (defun sepia-filter-by-all (x)
297 "Filter to limit hits by module and file."
298 (when (and (or (not module
) (string= module
(fourth x
)))
299 (or (not file
) (string= file
(first x
))))
302 (defmacro define-sepia-query
(name doc
&optional gen test prompt
)
303 `(defun ,name
(ident &optional module file line display-p
)
306 With prefix arg, list occurences in a ``grep-mode'' buffer.
307 Without, place the occurrences on ``sepia-found'', so that
308 calling ``sepia-next'' will cycle through them.
310 Depending on the query, MODULE, FILE, and LINE may be used to
311 narrow the results, as long as doing so leaves some matches.
312 When called interactively, they are taken from the current
315 (interactive (list (sepia-interactive-arg ,(or prompt
''function
))
316 (sepia-interactive-module)
318 (line-number-at-pos (point))
323 `(let ((tmp (,gen ident module file line
)))
324 (or (mapcan #',test tmp
) tmp
))
325 `(,gen ident module file line
))))
326 ;; Always clear out the last found ring, because it's confusing
328 (sepia-set-found nil
',(or prompt
'function
))
330 (sepia-show-locations ret
)
331 (sepia-set-found ret
',(or prompt
'function
))
334 (defun sepia-location (name)
335 (interactive (list (or (thing-at-point 'symbol
)
336 (completing-read "Function: " 'xref-completions
))))
337 (let ((fl (xref-location name
)))
339 (destructuring-bind (file line shortname
) fl
340 (if (string-match "^(eval " file
)
341 (error "Can't find definition of %s in %s." name file
)
342 (sepia-set-found (list fl
))
346 (defun sepia-dwim (&optional display-p
)
348 * Find all definitions, if thing-at-point is a function
349 * Find all uses, if thing-at-point is a variable
350 * Find all definitions, if thing-at-point is a module
354 (multiple-value-bind (obj mod type
) (sepia-ident-at-point)
357 (sepia-set-found nil type
)
358 (let ((ret (ecase type
359 (function (xref-defs obj mod
))
360 (variable (xref-var-uses obj mod
))
361 (module `((,(car (xref-mod-files mod
)) 1 nil nil
))))))
363 (sepia-show-locations ret
)
364 (sepia-set-found ret type
)
366 (call-interactively 'sepia-defs
))))
368 (define-sepia-query sepia-defs
369 "Find all definitions of sub."
372 (define-sepia-query sepia-uses
373 "Find all uses of sub (i.e. positions within its callers)."
375 (lambda (x) (setf (third x
) ident
) (list x
)))
377 (define-sepia-query sepia-callers
378 "Find callers of FUNC."
381 (define-sepia-query sepia-callees
382 "Find a sub's callees."
385 (define-sepia-query sepia-var-defs
386 "Find a var's definitions."
388 (lambda (x) (setf (third x
) ident
) (list x
))
391 (define-sepia-query sepia-var-uses
394 (lambda (x) (setf (third x
) ident
) (list x
))
397 (define-sepia-query sepia-var-assigns
398 "Find/list assignments to a variable."
400 (lambda (x) (setf (third x
) ident
) (list x
))
403 (define-sepia-query sepia-module-describe
404 "Find all subroutines in a package."
409 (defalias 'sepia-package-defs
'sepia-module-describe
)
411 (define-sepia-query sepia-apropos
412 "Find/list subroutines matching regexp."
417 (define-sepia-query sepia-var-apropos
418 "Find/list variables matching regexp."
423 (defun sepia-rebuild ()
424 "Rebuild the Xref database."
429 (defun sepia-load-file (file rebuild-p
)
430 "Reload a file, possibly rebuilding the Xref database. When
431 called interactively, reloads the current buffer's file, and
432 rebuilds the database unless a prefix argument is given."
433 (interactive (list (buffer-file-name) (not prefix-arg
)))
434 (perl-load-file file
)
439 (defvar sepia-found-head
)
440 (defvar sepia-found-refiner
)
441 (defvar sepia-history nil
)
443 (defun sepia-set-found (list &optional type
)
445 (remove-if (lambda (x)
446 (and (not (car x
)) (string= (fourth x
) "main")))
448 (setq sepia-found list
449 sepia-found-head list
)
450 (setq sepia-found-refiner
(sepia-refiner type
))
451 ;; (when (length list)
452 ;; (message "sepia: found %d %s%s." (length list)
454 ;; (if (= (length list) 1) "" "s")))
457 (defun sepia-refiner (type)
461 (let ((sub-re (concat "^\\s *sub\\s +.*" ident
"\\>")))
462 ;; Test this because sometimes we get lucky and get the line
463 ;; just right, in which case beginning-of-defun goes to the
465 (unless (looking-at sub-re
)
470 (looking-at sub-re
)))
471 (progn (goto-char (point-min))
472 (re-search-forward sub-re nil t
)))
473 (beginning-of-line)))))
474 ;; Old version -- this may actually work better if
475 ;; beginning-of-defun goes flaky on us.
476 ;; (or (re-search-backward sub-re
477 ;; (my-bol-from (point) -20) t)
478 ;; (re-search-forward sub-re
479 ;; (my-bol-from (point) 10) t))
480 ;; (beginning-of-line)
483 (let ((var-re (concat "\\<" ident
"\\>")))
485 (line (goto-line line
)
486 (or (re-search-backward var-re
(my-bol-from (point) -
5) t
)
487 (re-search-forward var-re
(my-bol-from (point) 5) t
)))
488 (t (goto-char (point-min))
489 (re-search-forward var-re nil t
))))))
490 (t (lambda (line ident
) (and line
(goto-line line
))))))
493 "Go to the next thing (e.g. def, use) found by sepia."
496 (destructuring-bind (file line short
&optional mod
&rest blah
)
499 (setq file
(and mod
(sepia-module-file mod
)))
501 (setf (caar sepia-found
) file
)
502 (error "No file for %s." (car sepia-found
))))
503 (message "%s at %s:%s" short file line
)
504 (when (file-exists-p file
)
505 (find-file (or file
(car (xref-mod-files mod
))))
506 (when sepia-found-refiner
507 (funcall sepia-found-refiner line short
))
510 (setq sepia-found
(or (cdr sepia-found
)
512 (message "sepia: no more defs.")
513 sepia-found-head
)))))
514 (message "No more definitions.")))
516 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
519 (defun sepia-ident-at-point ()
520 "Find the perl identifier at point, returning
521 \(values OBJECT MODULE TYPE RAW), where TYPE is either 'variable,
522 'function, or 'module. If TYPE is 'module, OBJ is the last
523 component of the module name."
524 (let ((cperl-under-as-char nil
)
525 (case-fold-search nil
)
526 var-p module-p modpart objpart
)
528 (destructuring-bind (sbeg . send
) (bounds-of-thing-at-point 'symbol
)
529 (destructuring-bind (wbeg . wend
) (or (bounds-of-thing-at-point 'word
)
530 (cons (point) (point)))
531 (if (member (char-before send
) '(?
> ?\
))
532 (signal 'wrong-number-of-arguments
'sorta
))
534 (or (member (char-before wbeg
) '(?
@ ?$ ?%
))
535 (member (char-before sbeg
) '(?
@ ?$ ?%
))))
537 (save-excursion (goto-char wbeg
) (looking-at "[A-Z]")))
541 (buffer-substring sbeg
542 (if (= (char-before (1- wbeg
)) ?\
:)
545 (setq objpart
(buffer-substring wbeg wend
))
547 (list objpart modpart
(if var-p
'variable
'function
))
550 (buffer-substring sbeg send
)
556 (buffer-substring sbeg send
))))
557 (wrong-number-of-arguments (values nil nil nil
)))))
559 (defun delete-thing-at-point (sym)
560 (destructuring-bind (beg . end
) (bounds-of-thing-at-point sym
)
561 (delete-region beg end
)))
563 (defun sepia-complete-symbol ()
564 "Try to complete the word at point:
565 * as a global variable, if it has a sigil (sorry, no lexical
567 * as a module, if its last namepart begins with an uppercase
569 * as a function, otherwise.
570 The function currently ignores module qualifiers, which may be
571 annoying in larger programs.
573 The function is intended to be bound to \\M-TAB, like
574 ``lisp-complete-symbol''."
576 (let ((tap (or (thing-at-point 'symbol
)
577 (and (eq last-command
'sepia-complete-symbol
) ""))))
579 (let ((completions (xref-completions tap
)))
580 (case (length completions
)
581 (0 (message "No completions for %s." tap
))
582 (1 (delete-thing-at-point 'symbol
)
583 (insert (car completions
)))
584 (t (delete-thing-at-point 'symbol
)
585 (insert (try-completion "" completions
))
586 (with-output-to-temp-buffer "*Completions*"
587 (display-completion-list completions
)))))
588 (message "sepia: empty -- hit tab again to complete."))))
590 (defun sepia-indent-or-complete ()
591 "Indent the current line and, if indentation doesn't move point,
592 complete the symbol around point. This function is intended to
596 (cperl-indent-command)
597 (when (and (= pos
(point))
598 (eq last-command
'sepia-indent-or-complete
))
599 (sepia-complete-symbol))))
601 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
605 (defun sepia-scratchpad ()
606 "Create a buffer to interact with a Perl interpreter. The buffer
607 is placed in cperl-mode; calling ``sepia-scratch-send-line'' will
608 evaluate the current line and display the result."
610 (switch-to-buffer (get-buffer-create "*perl-interaction*"))
612 (local-set-key "\C-j" 'sepia-scratch-send-line
))
614 (defun sepia-scratch-send-line (&optional scalarp
)
615 "Send the current line to perl, and display the result."
618 (sepia-eval (concat "do{"
619 (buffer-substring (my-bol-from (point))
620 (my-eol-from (point)))
623 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
626 (defun my-perl-frob-region (pre post beg end replace-p
)
627 (let* ((exp (concat pre
"\""
628 (shell-quote-argument (buffer-substring beg end
))
630 (new-str (format "%s" (perl-eval exp
'scalar-context
))))
632 (progn (delete-region beg end
)
637 (defun my-eol-from (pt &optional n
)
643 (defun my-bol-from (pt &optional n
)
646 (beginning-of-line n
)
649 (defun perl-pe-region (expr beg end
&optional replace-p
)
650 "Do the equivalent of perl -pe on region (i.e. evaluate an
651 expression on each line of region). With prefix arg, replace the
652 region with the result."
653 (interactive "MExpression:\nr\nP")
655 "{ my $ret='';my $region = "
656 (concat "; for (split /\n/, $region) { do { " expr
657 ";}; $ret.=\"$_\\n\"}; $ret}")
658 (my-bol-from beg
) (my-eol-from end
) replace-p
))
660 (defun perl-ize-region (expr beg end
&optional replace-p
)
661 "Evaluate a Perl expression on the region as a whole. With
662 prefix arg, replace the region with the result."
663 (interactive "MExpression:\nr\nP")
664 (my-perl-frob-region "{ local $_ = "
665 (concat "; do { " expr
";}; $_ }")
668 (defun sepia-guess-package (sub &optional file
)
669 "Guess which package SUB is defined in."
670 (let ((defs (xref-defs sub
)))
671 (or (and (= (length defs
) 1)
672 (or (not file
) (equal (caar defs
) file
))
675 (fourth (find-if (lambda (x) (equal (car x
) file
)) defs
)))
676 (car (xref-file-modules file
))
677 (sepia-buffer-package))))
680 (defun sepia-eval-defun ()
681 "Re-evaluate the current sub in the appropriate package, and
685 (let ((beg (progn (beginning-of-defun) (point)))
686 (end (progn (end-of-defun) (point))))
688 (when (looking-at "^sub\\s +\\([^ {]+\\)")
689 (let* ((sub (match-string 1))
691 (sepia-guess-package sub
(buffer-file-name)))
692 (body (buffer-substring-no-properties beg end
))
693 (sepia-eval-file (buffer-file-name))
694 (sepia-eval-line (line-number-at-pos beg
)))
695 (sepia-eval (if sepia-eval-defun-include-decls
697 (apply #'concat
(xref-mod-decls sepia-eval-package
))
700 (xref-redefined sub sepia-eval-package
)
701 (message "Defined %s" sub
))))))
703 (defun sepia-extract-def (file line obj mod
)
704 (with-current-buffer (find-file-noselect (expand-file-name file
))
706 (funcall (sepia-refiner 'function
) line obj
)
708 (when (looking-at (concat "^\\s *sub\\>.*\\<" obj
"\\>"))
709 (buffer-substring (point)
710 (progn (end-of-defun) (point)))))))
712 (defun sepia-eval-no-run (string)
715 (concat "BEGIN { use B; B::minus_c(); $^C=1; } { "
717 "} BEGIN { die \"ok\\n\" }"))
718 (perl-error (if (string-match "^ok\n" (cadr err
))
724 (defun sepia-eval-buffer (&optional no-update
)
725 "Re-evaluate the current file; unless prefix argument is given,
726 also rebuild the xref database."
728 (let ((sepia-eval-file (buffer-file-name)))
729 (sepia-eval-no-run (buffer-string))
733 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
736 (defvar sepia-eval-package
"main"
737 "Package in which ``sepia-eval'' evaluates perl expressions.")
738 (defvar sepia-eval-file nil
739 "File in which ``sepia-eval'' evaluates perl expressions.")
740 (defvar sepia-eval-line nil
741 "Line at which ``sepia-eval'' evaluates perl expressions.")
742 (defvar sepia-repl-hook nil
743 "Hook run after Sepia REPL starts.")
745 (defun sepia-repl-init-syntax ()
746 (local-unset-key ":")
747 (set-syntax-table cperl-mode-syntax-table
)
748 (modify-syntax-entry ?
> "."))
750 (defun sepia-set-eval-package (new-package)
751 (setq sepia-eval-package new-package
))
753 (defun sepia-get-eval-package ()
756 (defun sepia-eval (string &optional discard
)
757 "Evaluate STRING as Perl code, returning the pretty-printed
758 value of the last expression. If SOURCE-FILE is given, use this
759 as the file containing the code to be evaluated. XXX: this is
760 the only function that requires EPL (the rest can use Pmacs)."
761 (epl-eval (epl-init) nil
'scalar-context
763 "{ package " (or sepia-eval-package
"main") ";"
764 (if sepia-eval-file
(concat "$Devel::Xref::file = \"" sepia-eval-file
"\";")
766 (if sepia-eval-line
(format "$Devel::Xref::line = %d;" sepia-eval-line
)
769 (concat string
"; 'ok' }\n")
771 "require Data::Dumper;"
772 ;; "local $Data::Dumper::Indent=0;"
773 "local $Data::Dumper::Deparse=1;"
774 "local $_ = Data::Dumper::Dumper([do { " string
"}]);"
775 "s/^.*?=\\s*\\[//; s/\\];$//;$_}")))))
778 (defun sepia-interact ()
779 "Start or switch to a perl interaction buffer."
781 (unless (get-buffer "*perl-interaction*")
782 (generic-repl "perl"))
783 (pop-to-buffer (get-buffer "*perl-interaction*")))
785 (defun sepia-repl-header ()
786 (let ((proc (aref perl-interpreter
2)))
787 (format "%s [id=%d,d=%d,nr=%d] (%s)"
790 (aref perl-interpreter
7)
791 (aref perl-interpreter
5)
792 (process-status proc
))))
794 (defun sepia-set-repl-dir ()
796 (repl-cd default-directory
"perl"))
798 (defun sepia-set-cwd (dir)
799 (perl-call "chdir" dir
))
801 (defun sepia-input-complete-p (beg end
)
803 (let ((res (sepia-eval-no-run (buffer-substring beg end
))))
809 (unless (assoc "perl" repl-supported-modes
)
813 :complete sepia-complete-symbol
814 :header sepia-repl-header
816 :init
(lambda () (run-hooks 'sepia-repl-hook
))
818 :get-package sepia-get-eval-package
819 :expression-p sepia-input-complete-p
820 :set-package sepia-set-eval-package
)
821 repl-supported-modes
))
823 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
826 (defvar sepia-doc-map
(make-hash-table :test
#'equal
))
827 (defvar sepia-var-doc-map
(make-hash-table :test
#'equal
))
828 (defvar sepia-module-doc-map
(make-hash-table :test
#'equal
))
830 ;; (defvar sepia-use-long-doc t
831 ;; "Gather additional docs from POD following =item to report with eldoc.")
833 (defun sepia-doc-scan-buffer ()
835 (goto-char (point-min))
836 (loop while
(re-search-forward
837 "^=\\(item\\|head2\\)\\s +\\([%$&@A-Za-z_].*\\)" nil t
)
838 if
(let* ((s1 (match-string 2))
839 (s2 (let ((case-fold-search nil
))
840 (replace-regexp-in-string
842 (lambda (x) (match-string 1 s1
)) s1
)))
844 (let ((beg (progn (forward-line 2) (point)))
845 (end (1- (re-search-forward "^=" nil t
))))
848 (if (re-search-forward "^\\(.+\\)$" end t
)
850 (substring-no-properties
852 0 (position ?.
(match-string 1))))
855 ;; e.g. "C<foo(BLAH)>" or "$x = $y->foo()"
856 ((string-match "\\(\\sw+\\)\\s *\\($\\|(\\)" s2
)
857 (list 'function
(match-string-no-properties 1 s2
)
858 (or (and (equal s2
(match-string 1 s2
)) longdoc
) s2
)))
859 ;; e.g. "$x -- this is x" (note: this has to come second)
860 ((string-match "^[%$@]\\([^( ]+\\)" s2
)
861 (list 'variable
(match-string-no-properties 1 s2
) longdoc
))))
864 (defun sepia-buffer-package ()
866 (goto-char (point-min))
867 (or (and (re-search-forward "^\\s *package\\s +\\([^ ;]+\\)" nil t
)
871 (defun sepia-doc-update ()
872 "Update documentation for a file. This documentation, taken from
873 \"=item\" entries in the POD, is used for eldoc feedback."
876 (car (xref-file-modules (buffer-file-name)))
877 (sepia-buffer-package))
880 (dolist (x (sepia-doc-scan-buffer))
881 (let ((map (ecase (car x
)
882 (function sepia-doc-map
)
883 (variable sepia-var-doc-map
))))
884 (puthash (second x
) (third x
) map
)
885 (puthash (concat pack
(second x
)) (third x
) map
)))))
887 (defun sepia-symbol-info ()
888 "Eldoc function for Sepia-mode. Looks in ``sepia-doc-map'' and
889 ``sepia-var-doc-map'', then tries calling
890 ``cperl-describe-perl-symbol''."
892 (multiple-value-bind (obj mod type
) (sepia-ident-at-point)
894 (let ((map (ecase type
895 (function sepia-doc-map
)
896 (variable sepia-var-doc-map
)
897 (module sepia-module-doc-map
))))
902 ;; Loathe cperl a bit.
903 (flet ((message (&rest blah
) (apply #'format blah
)))
904 (let* ((cperl-message-on-help-error nil
)
905 (hlp (car (cperl-describe-perl-symbol obj
))))
907 ;; cperl's docstrings are too long.
908 (setq hlp
(replace-regexp-in-string "\\s \\{2,\\}" " " hlp
))
909 (if (> (length hlp
) 75)
910 (concat (substring hlp
0 72) "...")
914 (defun sepia-install-eldoc ()
915 "Install Sepia hooks for eldoc support (probably requires Emacs >= 21.3)."
917 (set (make-variable-buffer-local
918 'eldoc-print-current-symbol-info-function
)
920 (if cperl-lazy-installed
(cperl-lazy-unstall))
922 (setq eldoc-idle-delay
1.0))
924 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
927 (defun sepia-extract-next-warning (pos &optional end
)
928 (when (and (re-search-forward "^\\(.+\\) at \\(.+\\) line \\([0-9]+\\)\\.$"
930 (not (string= "(eval " (substring (match-string 2) 0 6))))
931 (list (match-string 2)
932 (read-from-string (match-string 3))
933 (msg (match-string 1)))))
935 (defun sepia-goto-error-at (pos)
936 "Visit the source of the error on line at POS (point if called
939 (ifa (sepia-extract-warning (my-bol-from pos
) (my-eol-from pos
))
940 (destructuring-bind (file line msg
) it
944 (error "No error to find.")))
946 (defun sepia-perl-display-errors (beg end
)
949 (loop with msgs
= (make-hash-table :test
#'equal
)
950 for w
= (sepia-extract-warning (my-bol-from (point)) end
)
952 do
(destructuring-bind (file line msg
) w
953 (puthash file msgs
(cons line msg
)))
955 (with-current-buffer (get-buffer-create "*perl-warnings*")
956 (let ((inhibit-read-only t
))
958 (dolist (k (sort (hash-table-keys msgs
) #'string
<))
959 (let ((v (gethash k msgs
)))
960 (insert (format "%s:%d:\n%s\n"
961 (abbreviate-file-name k
) (car v
) (cdr v
)))))
962 (goto-char (point-min))
966 ;;; sepia.el ends here