sepia.el

   1 ;;; Sepia -- Simple Emacs-Perl InterAction: ugly, yet effective.
   2 ;;; (a.k.a. Septik -- Sean's Emacs-Perl Total Integration Kludge.)
   3
   4 ;; Copyright (C) 2004 Sean O'Rourke.  All rights reserved, some wrongs
   5 ;; reversed.  This code is distributed under the same terms as Perl
   6 ;; itself.
   7
   8 ;;; Commentary:
   9
  10 ;; See the README file that comes with the distribution.
  11
  12 ;;; Code:
  13
  14 (require 'cperl-mode)
  15 (require 'comint)
  16 (require 'cl)
  17 (eval-when (load eval) (ignore-errors (require 'sepia-w3m)))
  18 (eval-when (load eval) (ignore-errors (require 'sepia-tree)))
  19 (eval-when (load eval) (ignore-errors (require 'sepia-ido)))
  20
  21 (defvar perl-process nil)
  22 (defvar perl-output nil)
  23
  24 (defun perl-collect-output (string)
  25   (setq perl-output (concat perl-output string))
  26   "")
  27
  28 (defun perl-eval-raw (str)
  29   (let ((perl-output "")
  30         (comint-preoutput-filter-functions '(perl-collect-output)))
  31     (comint-send-string perl-process
  32                         (concat "eval <<REPLEND\n" str "\nREPLEND\n"))
  33     (while (not (and perl-output
  34                      (string-match "REPLEND\n> $" perl-output)))
  35       (accept-process-output perl-process))
  36     (and (string-match "\nREPLEND\n\\(.*\\)\nREPLEND\n" perl-output)
  37          (match-string 1 perl-output))))
  38
  39 (defun perl-eval (str &optional context)
  40   (let ((res
  41          (perl-eval-raw
  42           (case context
  43             (list-context
  44              (concat "tolisp([" str "])"))
  45             (scalar-context
  46              (concat "tolisp(scalar(" str "))"))
  47             (t (concat str ";1;\n"))))))
  48     (when res
  49       (car (read-from-string res)))))
  50
  51 (defun perl-call (fn context &rest args)
  52   (perl-eval (concat fn "(" (mapconcat #'to-perl args ", ") ")") context))
  53
  54 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  55 ;;; Xrefs -- use Perl to find definitions and uses.
  56
  57 (defvar sepia-use-completion t
  58   "* Use completion based on Xref database.  Turning this off may
  59 speed up some operations, if you don't mind losing completion.")
  60
  61 (defvar sepia-eval-defun-include-decls t
  62   "* Generate and use a declaration list for ``sepia-eval-defun''.
  63 Without this, code often will not parse; with it, evaluation may
  64 be a bit less responsive.  Note that since this only includes
  65 subs from the evaluation package, it may not always work.")
  66
  67 (defvar sepia-prefix-key "\M-."
  68   "* Prefix for functions in ``sepia-keymap''.")
  69
  70 (defvar sepia-root (expand-file-name "~/src/perl/sepia")
  71   "* Location of Sepia support files.")
  72
  73 (defvar sepia-keymap
  74   (eval-when (load eval)
  75     (let ((km (make-sparse-keymap)))
  76       (dolist (kv '(("c" . sepia-callers)
  77                     ("C" . sepia-callees)
  78                     ("v" . sepia-var-uses)
  79                     ("V" . sepia-var-defs)
  80                     ;;            ("V" . sepia-var-assigns)
  81                     ;;            ("\M-." . sepia-dwim)
  82                     ("\M-." . sepia-location)
  83                     ("f" . sepia-defs)
  84                     ("r" . sepia-rebuild)
  85                     ("m" . sepia-module-find)
  86                     ("n" . sepia-next)))
  87         (define-key km (car kv) (cdr kv)))
  88       (when (featurep 'sepia-w3m)
  89         (define-key km "d" 'sepia-w3m-perldoc-this))
  90       (when (featurep 'sepia-ido)
  91         (define-key km "j" 'sepia-jump-to-symbol))
  92       km))
  93   "Keymap for Sepia functions.  This is just an example of how you
  94 might want to bind your keys, which works best when bound to
  95 `\\M-.'.")
  96
  97 (defun sepia-install-keys (&optional map)
  98 "Install Sepia bindings in the current local keymap."
  99   (interactive)
 100   (let ((map (or map (current-local-map))))
 101     (define-key map sepia-prefix-key sepia-keymap)
 102     (define-key map "\M-," 'sepia-next)
 103     (define-key map "\C-\M-x" 'sepia-eval-defun)
 104     (define-key map "\C-c\C-l" 'sepia-load-file)
 105     (define-key map "\C-c\C-d" 'sepia-w3m-view-pod)
 106     (define-key map (kbd "TAB") 'sepia-indent-or-complete)))
 107
 108 (defun perl-name (sym &optional mod)
 109   (setq sym (substitute ?_ ?-
 110                         (if (symbolp sym) (symbol-name sym) sym)))
 111   (if mod
 112       (concat mod "::" sym)
 113       sym))
 114
 115 (defun sepia-comint-setup ()
 116   (comint-mode)
 117   (set (make-local-variable 'comint-dynamic-complete-functions)
 118        '(sepia-complete-symbol comint-dynamic-complete-filename))
 119   (local-set-key (kbd "TAB") 'comint-dynamic-complete)
 120   (modify-syntax-entry ?: "_")
 121   (modify-syntax-entry ?> ".")
 122   )
 123
 124 ;;;###autoload
 125 (defun sepia-init (&optional noinit)
 126 "Perform the initialization necessary to start Sepia, a set of
 127 tools for developing Perl in Emacs.
 128
 129 The following keys are bound to the prefix
 130 ``sepia-prefix-key'' (`\\M-.' by default), which can be changed
 131 by setting ``sepia-prefix'' before calling ``sepia-init'':
 132
 133 \\{sepia-keymap}
 134
 135 In addition to these keys, Sepia defines the following keys,
 136 which may conflict with keys in your setup, but which are
 137 intended to shadow similar functionality in elisp-mode:
 138
 139 `\\C-c\\C-d'        ``sepia-w3m-view-pod''
 140 `\\C-c\\C-l'        ``sepia-load-file''
 141 `\\C-\\M-x'         ``sepia-eval-defun''
 142 `\\M-,'             ``sepia-next'' (shadows ``tags-loop-continue'')
 143 "
 144   (interactive "P")
 145   (ignore-errors
 146     (kill-process "perl")
 147     (setq perl-process nil))
 148   (unless noinit
 149     ;; Load perl defs:
 150     (setq perl-process
 151           (get-buffer-process
 152            (comint-exec (get-buffer-create "*perl-interaction*")
 153                         "perl" "/usr/bin/perl" nil
 154                         `("-I" ,sepia-root "-MData::Dumper"
 155                                "-MSepia" "-MXref"
 156                                "-e" "Sepia::repl(*STDIN)"))))
 157       (with-current-buffer "*perl-interaction*"
 158         (sepia-comint-setup))
 159       (accept-process-output perl-process 0 0.5)
 160
 161   ;; Create glue wrappers for Module::Info funcs.
 162   (dolist (x '((name "Find module name.  Does not require loading.")
 163                (version "Find module version.  Does not require loading.")
 164                (inc-dir
 165 "Find directory in which this module was found.  Does not require loading.")
 166                (file
 167 "Absolute path of file defining this module.  Does not require loading.")
 168                (is-core
 169 "Guess whether or not a module is part of the core distribution.
 170 Does not require loading.")
 171                (modules-used
 172 "List modules used by this module.  Requires loading.")
 173                (packages-inside
 174 "List sub-packages in this module.  Requires loading.")
 175                (superclasses
 176 "List module's superclasses.  Requires loading.")))
 177     (apply #'define-modinfo-function x))
 178
 179   ;; Create low-level wrappers for Sepia
 180   (dolist (x '((completions "Find completions in the symbol table.")
 181                (location "Find an identifier's location.")
 182                (mod-subs "Find all subs defined in a package.")
 183                (mod-decls "Generate declarations for subs in a package.")
 184                (apropos "Find subnames matching RE.")
 185                (lexicals "Find lexicals for a sub.")
 186                ))
 187     (apply #'define-xref-function "Sepia" x))
 188
 189   (dolist (x '((rebuild "Build Xref database for current Perl process.")
 190                (redefined "Rebuild Xref information for a given sub.")
 191
 192                (callers "Find all callers of a function.")
 193                (callees "Find all functions called by a function.")
 194
 195                (var-apropos "Find varnames matching RE.")
 196                (mod-apropos "Find modules matching RE.")
 197                (file-apropos "Find files matching RE.")
 198
 199                (var-defs "Find all definitions of a variable.")
 200                (var-assigns "Find all assignments to a variable.")
 201                (var-uses "Find all uses of a variable.")
 202
 203                (mod-redefined "Rebuild Xref information for a given package.")
 204                (mod-files "Find the file defining a package.")
 205                (guess-module-file "Guess file corresponding to module.")
 206                (file-modules "List the modules defined in a file.")))
 207     (apply #'define-xref-function "Sepia::Xref" x)))
 208   (add-hook 'cperl-mode-hook 'sepia-install-eldoc)
 209   (add-hook 'cperl-mode-hook 'sepia-doc-update)
 210   (when (boundp 'cperl-mode-map)
 211     (sepia-install-keys cperl-mode-map))
 212   (when (boundp 'perl-mode-map)
 213     (sepia-install-keys perl-mode-map))
 214   (sepia-interact))
 215
 216 (defun define-xref-function (package name doc)
 217   "Define a lisp mirror for a low-level Sepia function."
 218   (let ((lisp-name (intern (format "xref-%s" name)))
 219         (pl-name (perl-name name package)))
 220     (fmakunbound lisp-name)
 221     (eval `(defun ,lisp-name (&rest args)
 222              ,doc
 223              (apply #'perl-call ,pl-name 'list-context args)))))
 224
 225 (defun define-modinfo-function (name &optional doc)
 226 "Define a lisp mirror for a function from Module::Info."
 227   (let ((name (intern (format "sepia-module-%s" name)))
 228         (pl-func (perl-name name))
 229         (full-doc (concat (or doc "") "
 230
 231 This function uses Module::Info, so it does not require that the
 232 module in question be loaded.")))
 233     (when (fboundp name) (fmakunbound name))
 234     (eval `(defun ,name (mod)
 235              ,full-doc
 236              (interactive (list (sepia-interactive-arg 'module)))
 237              (sepia-maybe-echo
 238               (perl-call "Sepia::module_info" 'scalar-context
 239                          mod ,pl-func))))))
 240
 241 (defun sepia-thing-at-point (what)
 242   "Like ``thing-at-point'', but hacked to avoid REPL prompt."
 243   (let ((th (thing-at-point what)))
 244     (and th (not (string-match "[ >]$" th)) th)))
 245
 246 (defun sepia-beginning-of-defun (where)
 247   (interactive "d")
 248   (beginning-of-defun)
 249   (let* ((end (point))
 250          (beg (progn (previous-line 3) (point))))
 251     (goto-char end)
 252     (re-search-backward "^\\s *sub\\s +\\(.+\\_>\\)" beg t)))
 253
 254 (defun sepia-defun-around-point (where)
 255   (interactive "d")
 256   (save-excursion
 257     (and (sepia-beginning-of-defun where)
 258          (match-string-no-properties 1))))
 259
 260 (defun sepia-lexicals-at-point (where)
 261   (interactive "d")
 262   (let ((subname (sepia-defun-around-point where))
 263         (mod (sepia-buffer-package)))
 264     (xref-lexicals (perl-name subname mod))))
 265
 266 (defun sepia-interactive-arg (&optional type)
 267 "Default argument for most Sepia functions.  TYPE is a symbol --
 268 either 'file to look for a file, or anything else to use the
 269 symbol at point."
 270   (let* ((default (case type
 271                     (file (or (thing-at-point 'file) (buffer-file-name)))
 272                     (t (sepia-thing-at-point 'symbol))))
 273          (text (capitalize (symbol-name type)))
 274          (choices (lambda (str &rest blah)
 275                     (let ((str (concat "^" str)))
 276                       (case type
 277                         (variable (xref-var-apropos str))
 278                         (function (xref-apropos str))
 279                         (module (xref-mod-apropos str))
 280                         (t nil)))))
 281          (ret (if sepia-use-completion
 282                   (completing-read (format "%s [%s]: " text default)
 283                                    choices nil nil nil 'sepia-history
 284                                    default)
 285                   (read-string (format "%s [%s]: " text default)
 286                                nil 'sepia-history default))))
 287     (push ret sepia-history)
 288     ret))
 289
 290 (defun sepia-interactive-module ()
 291 "Guess which module we should look things up in.  Prompting for a
 292 module all the time is a PITA, but I don't think this (choosing
 293 the current file's module) is a good alternative, either.  Best
 294 would be to choose the module based on what we know about the
 295 symbol at point."
 296   (let ((xs (xref-file-modules (buffer-file-name))))
 297     (if (= (length xs) 1)
 298         (car xs)
 299         nil)))
 300
 301 (defun sepia-maybe-echo (result)
 302   (when (interactive-p)
 303     (message "%s" result))
 304   result)
 305
 306 (defun sepia-module-find (mod)
 307 "Find the file defining module MOD."
 308   (interactive (list (sepia-interactive-arg 'module)))
 309   (let ((fn (or (sepia-module-file mod)
 310                 (car (xref-guess-module-file mod)))))
 311     (when fn
 312       (message "Module %s in %s." mod fn)
 313       (pop-to-buffer (find-file-noselect (expand-file-name fn))))))
 314
 315 (defmacro ifa (test then &rest else)
 316   `(let ((it ,test))
 317      (if it ,then ,@else)))
 318
 319 (defun sepia-show-locations (locs)
 320   (when locs
 321     (pop-to-buffer (get-buffer-create "*sepia-places*"))
 322     (erase-buffer)
 323     (dolist (loc (sort locs (lambda (a b)
 324                               (or (string< (car a) (car b))
 325                                   (and (string= (car a) (car b))
 326                                        (< (second a) (second b)))))))
 327       (destructuring-bind (file line name &rest blah) loc
 328         (let ((str (ifa (find-buffer-visiting file)
 329                         (with-current-buffer it
 330                           (ifa sepia-found-refiner
 331                                (funcall it line name)
 332                                (goto-line line))
 333                           (message "line for %s was %d, now %d" name line
 334                                    (line-number-at-pos))
 335                           (setq line (line-number-at-pos))
 336                           (let ((tmpstr
 337                                  (buffer-substring (my-bol-from (point))
 338                                                    (my-eol-from (point)))))
 339                             (if (> (length tmpstr) 60)
 340                                 (concat "\n    " tmpstr)
 341                                 tmpstr)))
 342                         "...")))
 343           (insert (format "%s:%d:%s\n" (abbreviate-file-name file) line str)))))
 344     (grep-mode)
 345     (goto-char (point-min))))
 346
 347 (defun sepia-filter-by-module (x)
 348   "Filter to limit hits by module only."
 349   (when (or (not module) (string= module (fourth x)))
 350     (list x)))
 351
 352 (defun sepia-filter-by-all (x)
 353   "Filter to limit hits by module and file."
 354   (when (and (or (not module) (string= module (fourth x)))
 355              (or (not file) (string= file (first x))))
 356     (list x)))
 357
 358 (defmacro define-sepia-query (name doc &optional gen test prompt)
 359   `(defun ,name (ident &optional module file line display-p)
 360      ,(concat doc "
 361
 362 With prefix arg, list occurences in a ``grep-mode'' buffer.
 363 Without, place the occurrences on ``sepia-found'', so that
 364 calling ``sepia-next'' will cycle through them.
 365
 366 Depending on the query, MODULE, FILE, and LINE may be used to
 367 narrow the results, as long as doing so leaves some matches.
 368 When called interactively, they are taken from the current
 369 buffer.
 370 ")
 371      (interactive (list (sepia-interactive-arg ,(or prompt ''function))
 372                         (sepia-interactive-module)
 373                         (buffer-file-name)
 374                         (line-number-at-pos (point))
 375                         current-prefix-arg
 376                         ))
 377      (let ((ret
 378             ,(if test
 379                  `(let ((tmp (,gen ident module file line)))
 380                     (or (mapcan #',test tmp) tmp))
 381                  `(,gen ident module file line))))
 382        ;; Always clear out the last found ring, because it's confusing
 383        ;; otherwise.
 384        (sepia-set-found nil ',(or prompt 'function))
 385        (if display-p
 386            (sepia-show-locations ret)
 387            (sepia-set-found ret ',(or prompt 'function))
 388            (sepia-next)))))
 389
 390 (defun sepia-location (name &optional jump-to)
 391   (interactive (list (or (thing-at-point 'symbol)
 392                          (completing-read "Function: " 'xref-completions))
 393                      t))
 394   (let* ((fl (or (car (xref-location name))
 395                  (car (remove-if #'null
 396                                  (apply #'xref-location (xref-apropos name)))))))
 397     (when (and fl (string-match "^(eval " (car fl)))
 398       (message "Can't find definition of %s in %s." name (car fl))
 399       (setq fl nil))
 400     (if jump-to
 401         (if fl (progn
 402                  (sepia-set-found (list fl) 'function)
 403                  (sepia-next))
 404             (message "No definition for %s." name))
 405         fl)))
 406
 407 ;;;###autoload
 408 (defun sepia-dwim (&optional display-p)
 409     "Try to DWIM:
 410 * Find all definitions, if thing-at-point is a function
 411 * Find all uses, if thing-at-point is a variable
 412 * Find all definitions, if thing-at-point is a module
 413 * Prompt otherwise
 414 "
 415     (interactive "P")
 416     (multiple-value-bind (obj mod type raw) (sepia-ident-at-point)
 417       (message "%S" (list obj mod type raw))
 418       (if type
 419           (progn
 420             (sepia-set-found nil type)
 421             (let ((ret (ecase type
 422                          (function (list (sepia-location raw)))
 423                          (variable (xref-var-uses raw))
 424                          (module `((,(car (xref-mod-files mod)) 1 nil nil))))))
 425               (if display-p
 426                   (sepia-show-locations ret)
 427                   (sepia-set-found ret type)
 428                   (sepia-next))))
 429           (call-interactively 'sepia-defs))))
 430
 431 (define-sepia-query sepia-defs
 432     "Find all definitions of sub."
 433   xref-apropos
 434   xref-location)
 435
 436 (define-sepia-query sepia-callers
 437     "Find callers of FUNC."
 438   xref-callers
 439   xref-location)
 440
 441 (define-sepia-query sepia-callees
 442     "Find a sub's callees."
 443   xref-callees
 444   xref-location)
 445
 446 (define-sepia-query sepia-var-defs
 447     "Find a var's definitions."
 448   xref-var-defs
 449   (lambda (x) (setf (third x) ident) (list x))
 450   'variable)
 451
 452 (define-sepia-query sepia-var-uses
 453     "Find a var's uses."
 454   xref-var-uses
 455   (lambda (x) (setf (third x) ident) (list x))
 456   'variable)
 457
 458 (define-sepia-query sepia-var-assigns
 459     "Find/list assignments to a variable."
 460   xref-var-assigns
 461   (lambda (x) (setf (third x) ident) (list x))
 462   'variable)
 463
 464 (define-sepia-query sepia-module-describe
 465     "Find all subroutines in a package."
 466   xref-mod-subs
 467   nil
 468   'module)
 469
 470 (defalias 'sepia-package-defs 'sepia-module-describe)
 471
 472 (define-sepia-query sepia-apropos
 473     "Find/list subroutines matching regexp."
 474   (lambda (name &rest blah) (xref-apropos name 1))
 475   xref-location
 476   'function)
 477
 478 (define-sepia-query sepia-var-apropos
 479     "Find/list variables matching regexp."
 480   xref-var-apropos
 481   xref-var-defs
 482   'variable)
 483
 484 (defun sepia-rebuild ()
 485   "Rebuild the Xref database."
 486   (interactive)
 487   (xref-rebuild))
 488
 489 ;;;###autoload
 490 (defun sepia-load-file (file &optional rebuild-p collect-warnings)
 491   "Reload a file.  With REBUILD-P (or a prefix argument when
 492 called interactively), also rebuild the xref database."
 493   (interactive (progn (save-buffer)
 494                       (list (buffer-file-name)
 495                             prefix-arg
 496                             (format "*%s errors*" (buffer-file-name)))))
 497   (message
 498    "sepia: %s returned %s"
 499    (abbreviate-file-name file)
 500    (perl-eval
 501     (if collect-warnings
 502         (format "{ local $SIG{__WARN__} = Sepia::emacs_warner('%s'); do '%s' }"
 503                 collect-warnings file)
 504         (format "do '%s';" file))))
 505   (when collect-warnings
 506     (with-current-buffer (get-buffer-create collect-warnings)
 507       (sepia-display-errors (point-min) (point-max))
 508       (if (> (buffer-size) 0)
 509           (pop-to-buffer (current-buffer))
 510           (kill-buffer (current-buffer)))))
 511   (when rebuild-p
 512     (xref-rebuild)))
 513
 514 (defvar sepia-found)
 515 (defvar sepia-found-head)
 516 (defvar sepia-found-refiner)
 517 (defvar sepia-history nil)
 518
 519 (defun sepia-set-found (list &optional type)
 520   (setq list
 521         (remove-if (lambda (x)
 522                      (and (not (car x)) (string= (fourth x) "main")))
 523                    list))
 524   (setq sepia-found list
 525         sepia-found-head list)
 526   (setq sepia-found-refiner (sepia-refiner type)))
 527
 528 (defun sepia-refiner (type)
 529   (case type
 530     (function
 531      (lambda (line ident)
 532       (let ((sub-re (concat "^\\s *sub\\s +.*" ident "\\_>")))
 533         ;; Test this because sometimes we get lucky and get the line
 534         ;; just right, in which case beginning-of-defun goes to the
 535         ;; previous defun.
 536         (unless (looking-at sub-re)
 537           (or (and line
 538                    (progn
 539                      (goto-line line)
 540                      (beginning-of-defun)
 541                      (looking-at sub-re)))
 542               (progn (goto-char (point-min))
 543                      (re-search-forward sub-re nil t)))
 544           (beginning-of-line)))))
 545     ;; Old version -- this may actually work better if
 546     ;; beginning-of-defun goes flaky on us.
 547 ;;         (or (re-search-backward sub-re
 548 ;;                                 (my-bol-from (point) -20) t)
 549 ;;             (re-search-forward sub-re
 550 ;;                                (my-bol-from (point) 10) t))
 551 ;;         (beginning-of-line)
 552     (variable
 553      (lambda (line ident)
 554        (let ((var-re (concat "\\_<" ident "\\_>")))
 555          (cond
 556            (line (goto-line line)
 557                  (or (re-search-backward var-re (my-bol-from (point) -5) t)
 558                      (re-search-forward var-re (my-bol-from (point) 5) t)))
 559            (t (goto-char (point-min))
 560               (re-search-forward var-re nil t))))))
 561     (t (lambda (line ident) (and line (goto-line line))))))
 562
 563 (defun sepia-next ()
 564 "Go to the next thing (e.g. def, use) found by sepia."
 565   (interactive)
 566   (if sepia-found
 567       (destructuring-bind (file line short &optional mod &rest blah)
 568           (car sepia-found)
 569         (unless file
 570           (setq file (and mod (sepia-module-file mod)))
 571           (if file
 572               (setf (caar sepia-found) file)
 573               (error "No file for %s." (car sepia-found))))
 574         (message "%s at %s:%s" short file line)
 575         (when (file-exists-p file)
 576           (find-file (or file (car (xref-mod-files mod))))
 577           (when sepia-found-refiner
 578             (funcall sepia-found-refiner line short))
 579           (beginning-of-line)
 580           (recenter)
 581           (setq sepia-found (or (cdr sepia-found)
 582                                 (progn
 583                                   (message "sepia: no more defs.")
 584                                   sepia-found-head)))))
 585       (message "No more definitions.")))
 586
 587 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 588 ;; Completion
 589
 590 (defun sepia-ident-at-point ()
 591   "Find the perl identifier at point, returning
 592 \(values OBJECT MODULE TYPE RAW), where TYPE is either 'variable,
 593 'function, or 'module.  If TYPE is 'module, OBJ is the last
 594 component of the module name."
 595   (let ((cperl-under-as-char nil)
 596         (case-fold-search nil)
 597         var-p module-p modpart objpart)
 598     (save-excursion
 599       (condition-case c
 600           (destructuring-bind (sbeg . send) (bounds-of-thing-at-point 'symbol)
 601             (goto-char send)
 602             (destructuring-bind (wbeg . wend)
 603                 (or (bounds-of-thing-at-point 'word) (cons (point) (point)))
 604               (if (member (char-before send) '(?> ?\ ))
 605                   (signal 'wrong-number-of-arguments 'sorta))
 606               (setq var-p
 607                     (or (and (member (char-before wbeg) '(?@ ?$ ?%))
 608                              (char-before wbeg))
 609                         (and (member (char-before sbeg) '(?@ ?$ ?%))
 610                              (char-before sbeg))))
 611               (setq module-p
 612                     (save-excursion
 613                       (goto-char send)
 614                       (backward-word)
 615                       (looking-at "[A-Z]")))
 616               (setq modpart
 617                     (if (= sbeg wbeg)
 618                         nil
 619                         (buffer-substring sbeg
 620                                           (if (= (char-before (1- wbeg)) ?\:)
 621                                               (- wbeg 2)
 622                                               (1- wbeg)))))
 623               (setq objpart (buffer-substring wbeg wend))
 624               (values (if module-p
 625                           (list objpart modpart (if var-p 'variable 'function))
 626                           objpart)
 627                       (if module-p
 628                           (buffer-substring sbeg send)
 629                           modpart)
 630                       (cond
 631                         (module-p 'module)
 632                         (var-p 'variable)
 633                         (t 'function))
 634                       (concat (if var-p (char-to-string var-p) "")
 635                               (buffer-substring sbeg send)))))
 636         (wrong-number-of-arguments (values nil nil nil))))))
 637
 638 ;; (defun delete-ident-at-point ()
 639 ;;   (destructuring-bind (beg . end) (bounds-of-thing-at-point sym)
 640 ;;     (delete-region beg end)))
 641
 642 (defun sepia-complete-symbol ()
 643   "Try to complete the word at point, either as a global variable if it
 644 has a sigil (sorry, no lexicals), a module, or a function.  The
 645 function currently ignores module qualifiers, which may be
 646 annoying in larger programs.
 647
 648 The function is intended to be bound to \\M-TAB, like
 649 ``lisp-complete-symbol''."
 650   (interactive)
 651   (multiple-value-bind (name mod type raw-name) (sepia-ident-at-point)
 652     (let ((tap (or raw-name
 653                    (and (eq last-command 'sepia-complete-symbol) ""))))
 654       (when tap
 655           (let ((completions (xref-completions tap (sepia-buffer-package))))
 656             (case (length completions)
 657               (0 (message "No completions for %s." tap) nil)
 658               (1 ;; (delete-ident-at-point)
 659                (delete-region (- (point) (length tap)) (point))
 660                (insert (car completions))
 661                t)
 662               (t (let ((old tap)
 663                        (new (try-completion "" completions)))
 664                    (if (string= new old)
 665                        (with-output-to-temp-buffer "*Completions*"
 666                          (display-completion-list completions))
 667 ;;                        (delete-region ...)
 668 ;;                        (delete-ident-at-point)
 669                        (delete-region (- (point) (length tap)) (point))
 670                        (insert new)))
 671                  t)))
 672 ;;           (message "sepia: empty -- hit tab again to complete.")
 673           ))))
 674
 675 (defun sepia-indent-or-complete ()
 676 "Indent the current line and, if indentation doesn't move point,
 677 complete the symbol around point.  This function is intended to
 678 be bound to TAB."
 679   (interactive)
 680   (let ((pos (point)))
 681     (cperl-indent-command)
 682     (when (and (= pos (point))
 683                (eq last-command 'sepia-indent-or-complete))
 684       (sepia-complete-symbol))))
 685
 686 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 687 ;;; scratchpad code
 688
 689 ;;;###autoload
 690 (defun sepia-scratch ()
 691 "Create a buffer to interact with a Perl interpreter.  The buffer
 692 is placed in cperl-mode; calling ``sepia-scratch-send-line'' will
 693 evaluate the current line and display the result."
 694   (interactive)
 695   (switch-to-buffer (get-buffer-create "*perl-scratch*"))
 696   (cperl-mode)
 697   (local-set-key "\C-j" 'sepia-scratch-send-line))
 698
 699 (defun sepia-scratch-send-line (&optional scalarp)
 700 "Send the current line to perl, and display the result."
 701   (interactive "P")
 702   (insert
 703    (sepia-eval (concat "do{"
 704                        (buffer-substring (my-bol-from (point))
 705                                          (my-eol-from (point)))
 706                        "}"))))
 707
 708 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 709 ;; Miscellany
 710
 711 (defun my-perl-frob-region (pre post beg end replace-p)
 712   (let* ((exp (concat pre "\""
 713                       (shell-quote-argument (buffer-substring beg end))
 714                       "\"" post))
 715          (new-str (format "%s" (perl-eval exp 'scalar-context))))
 716     (if replace-p
 717         (progn (delete-region beg end)
 718                (goto-char beg)
 719                (insert new-str))
 720         (message new-str))))
 721
 722 (defun my-eol-from (pt &optional n)
 723   (save-excursion
 724     (goto-char pt)
 725     (end-of-line n)
 726     (point)))
 727
 728 (defun my-bol-from (pt &optional n)
 729   (save-excursion
 730     (goto-char pt)
 731     (beginning-of-line n)
 732     (point)))
 733
 734 (defun perl-pe-region (expr beg end &optional replace-p)
 735 "Do the equivalent of perl -pe on region (i.e. evaluate an
 736 expression on each line of region).  With prefix arg, replace the
 737 region with the result."
 738   (interactive "MExpression: \nr\nP")
 739   (my-perl-frob-region
 740    "{ my $ret='';my $region = "
 741    (concat "; for (split /\n/, $region) { do { " expr
 742            ";}; $ret.=\"$_\\n\"}; $ret}")
 743    (my-bol-from beg) (my-eol-from end) replace-p))
 744
 745 (defun perl-ne-region (expr beg end &optional replace-p)
 746 "Do the moral equivalent of perl -ne on region (i.e. evaluate an
 747 expression on each line of region).  With prefix arg, replace the
 748 region with the result."
 749   (interactive "MExpression:\nr\nP")
 750   (my-perl-frob-region
 751    "{ my $ret='';my $region = "
 752    (concat "; for (split /\n/, $region) { $ret .= do { " expr
 753            ";} }; $ret}")
 754    (my-bol-from beg) (my-eol-from end) replace-p))
 755
 756 (defun perl-ize-region (expr beg end &optional replace-p)
 757 "Evaluate a Perl expression on the region as a whole.  With
 758 prefix arg, replace the region with the result."
 759   (interactive "MExpression:\nr\nP")
 760   (my-perl-frob-region "{ local $_ = "
 761                        (concat "; do { " expr ";}; $_ }")
 762                        beg end replace-p))
 763
 764 (defun sepia-guess-package (sub &optional file)
 765   "Guess which package SUB is defined in."
 766   (let ((defs (xref-location (xref-apropos sub))))
 767     (or (and (= (length defs) 1)
 768              (or (not file) (equal (caar defs) file))
 769              (fourth (car defs)))
 770         (and file
 771              (fourth (find-if (lambda (x) (equal (car x) file)) defs)))
 772         (car (xref-file-modules file))
 773         (sepia-buffer-package))))
 774
 775 ;;;###autoload
 776 (defun sepia-eval-defun ()
 777   "Re-evaluate the current sub in the appropriate package, and
 778 rebuild its Xrefs."
 779   (interactive)
 780   (save-excursion
 781     (let* ((pt (point))
 782            (end (progn (end-of-defun) (point)))
 783            (beg (progn (sepia-beginning-of-defun pt) (point))))
 784       (goto-char beg)
 785       (when (looking-at "^sub\\s +\\(.+\\_>\\)")
 786         (let* ((sub (match-string 1))
 787                (sepia-eval-package
 788                 (sepia-guess-package sub (buffer-file-name)))
 789                (body (buffer-substring-no-properties beg end))
 790                (sepia-eval-file (buffer-file-name))
 791                (sepia-eval-line (line-number-at-pos beg)))
 792           (sepia-eval (if sepia-eval-defun-include-decls
 793                           (concat
 794                            (apply #'concat (xref-mod-decls sepia-eval-package))
 795                            body)
 796                           body))
 797           (xref-redefined sub sepia-eval-package)
 798           (message "Defined %s" sub))))))
 799
 800 (defun sepia-extract-def (file line obj mod)
 801   (with-current-buffer (find-file-noselect (expand-file-name file))
 802     (save-excursion
 803       (funcall (sepia-refiner 'function) line obj)
 804       (beginning-of-line)
 805       (when (looking-at (concat "^\\s *sub\\_>.*\\_<" obj "\\_>"))
 806         (buffer-substring (point)
 807                           (progn (end-of-defun) (point)))))))
 808
 809 (defun sepia-eval-no-run (string &optional discard collect-warnings)
 810   (condition-case err
 811       (sepia-eval
 812        (concat "BEGIN { use B; B::minus_c(); $^C=1; } { "
 813                string
 814                "} BEGIN { die \"ok\\n\" }")
 815        discard collect-warnings)
 816     (perl-error (if (string-match "^ok\n" (cadr err))
 817                     nil
 818                     (cadr err)))
 819     (error err)))
 820
 821 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 822 ;; REPL
 823
 824 (defvar sepia-eval-package "main"
 825   "Package in which ``sepia-eval'' evaluates perl expressions.")
 826 (defvar sepia-eval-file nil
 827   "File in which ``sepia-eval'' evaluates perl expressions.")
 828 (defvar sepia-eval-line nil
 829   "Line at which ``sepia-eval'' evaluates perl expressions.")
 830
 831 (defun sepia-set-eval-package (new-package)
 832   (setq sepia-eval-package new-package))
 833
 834 (defun sepia-get-eval-package ()
 835   sepia-eval-package)
 836
 837 (defun sepia-eval (string &optional discard collect-warnings)
 838   "Evaluate STRING as Perl code, returning the pretty-printed
 839 value of the last expression.  If SOURCE-FILE is given, use this
 840 as the file containing the code to be evaluated.  XXX: this is
 841 the only function that requires EPL (the rest can use Pmacs)."
 842   (perl-eval-raw
 843    (concat
 844  "{ package " (or sepia-eval-package "main") ";"
 845  (if sepia-eval-file (concat "$Sepia::Xref::file = \"" sepia-eval-file "\";")
 846      "")
 847  (if sepia-eval-line (format "$Sepia::Xref::line = %d;\n#line %d\n"
 848                              sepia-eval-line sepia-eval-line)
 849      "")
 850  (if discard
 851      (concat string "; '' }\n")
 852      (concat
 853       "require Data::Dumper;"
 854 ;;       "local $Data::Dumper::Indent=0;"
 855       "local $Data::Dumper::Deparse=1;"
 856       (if sepia-eval-line (format "\n#line %d\n" sepia-eval-line) "")
 857       "my $result = Data::Dumper::Dumper([do { " string "}]);"
 858       "$result =~ s/^.*?=\\s*\\[//; $result =~ s/\\];$//;$result}")))))
 859
 860 ;;;###autoload
 861 (defun sepia-interact ()
 862 "Start or switch to a perl interaction buffer."
 863   (interactive)
 864   (pop-to-buffer (get-buffer "*perl-interaction*")))
 865
 866 (defun sepia-set-cwd (dir)
 867   (perl-call "Cwd::chdir" dir))
 868
 869 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 870 ;; Doc-scanning
 871
 872 (defvar sepia-doc-map (make-hash-table :test #'equal))
 873 (defvar sepia-var-doc-map (make-hash-table :test #'equal))
 874 (defvar sepia-module-doc-map (make-hash-table :test #'equal))
 875
 876 (defun sepia-doc-scan-buffer ()
 877   (save-excursion
 878     (goto-char (point-min))
 879     (loop while (re-search-forward
 880                  "^=\\(item\\|head2\\)\\s +\\([%$&@A-Za-z_].*\\)" nil t)
 881        if (let* ((s1 (match-string 2))
 882                  (s2 (let ((case-fold-search nil))
 883                        (replace-regexp-in-string
 884                         "[A-Z]<\\([^>]+\\)>"
 885                         (lambda (x) (match-string 1 s1)) s1)))
 886                  (longdoc
 887                   (let ((beg (progn (forward-line 2) (point)))
 888                         (end (1- (re-search-forward "^=" nil t))))
 889                     (forward-line -1)
 890                     (goto-char beg)
 891                     (if (re-search-forward "^\\(.+\\)$" end t)
 892                         (concat s2 ": "
 893                                 (substring-no-properties
 894                                  (match-string 1)
 895                                  0 (position ?. (match-string 1))))
 896                         s2))))
 897             (cond
 898               ;; e.g. "C<foo(BLAH)>" or "$x = $y->foo()"
 899               ((string-match "\\(\\sw+\\)\\s *\\($\\|(\\)" s2)
 900                (list 'function (match-string-no-properties 1 s2)
 901                      (or (and (equal s2 (match-string 1 s2)) longdoc) s2)))
 902               ;; e.g. "$x -- this is x" (note: this has to come second)
 903               ((string-match "^[%$@]\\([^( ]+\\)" s2)
 904                (list 'variable (match-string-no-properties 1 s2) longdoc))))
 905        collect it)))
 906
 907 (defun sepia-buffer-package ()
 908   (save-excursion
 909     (goto-char (point-min))
 910     (or (and (re-search-forward "^\\s *package\\s +\\([^ ;]+\\)" nil t)
 911              (match-string-no-properties 1))
 912         "main")))
 913
 914 (defun sepia-doc-update ()
 915 "Update documentation for a file.  This documentation, taken from
 916 \"=item\" entries in the POD, is used for eldoc feedback."
 917   (interactive)
 918   (let ((pack (ifa (or
 919                     (car (xref-file-modules (buffer-file-name)))
 920                     (sepia-buffer-package))
 921                    (concat it "::")
 922                    "")))
 923     (dolist (x (sepia-doc-scan-buffer))
 924       (let ((map (ecase (car x)
 925                    (function sepia-doc-map)
 926                    (variable sepia-var-doc-map))))
 927         (puthash (second x) (third x) map)
 928         (puthash (concat pack (second x)) (third x) map)))))
 929
 930 (defun sepia-symbol-info ()
 931 "Eldoc function for Sepia-mode.  Looks in ``sepia-doc-map'' and
 932 ``sepia-var-doc-map'', then tries calling
 933 ``cperl-describe-perl-symbol''."
 934   (save-excursion
 935     (multiple-value-bind (obj mod type) (sepia-ident-at-point)
 936       (or (when type
 937             (let ((map (ecase type
 938                          (function sepia-doc-map)
 939                          (variable sepia-var-doc-map)
 940                          (module sepia-module-doc-map))))
 941               (if mod
 942                   (gethash mod map)
 943                   (gethash obj map))))
 944           (when obj
 945             ;; Loathe cperl a bit.
 946             (when (consp obj)
 947               (setq obj (car obj)))
 948             (flet ((message (&rest blah) (apply #'format blah)))
 949               (let* ((cperl-message-on-help-error nil)
 950                      (hlp (car (cperl-describe-perl-symbol obj))))
 951                 (when hlp
 952                   ;; cperl's docstrings are too long.
 953                   (setq hlp (replace-regexp-in-string "\\s \\{2,\\}" "  " hlp))
 954                   (if (> (length hlp) 75)
 955                       (concat (substring hlp 0 72) "...")
 956                       hlp)))))
 957           ""))))
 958
 959 (defun sepia-install-eldoc ()
 960 "Install Sepia hooks for eldoc support (probably requires Emacs >= 21.3)."
 961   (interactive)
 962   (set (make-variable-buffer-local
 963         'eldoc-print-current-symbol-info-function)
 964        #'sepia-symbol-info)
 965   (if cperl-lazy-installed (cperl-lazy-unstall))
 966   (eldoc-mode 1)
 967   (setq eldoc-idle-delay 1.0))
 968
 969 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 970 ;; Error jump:
 971
 972 (defun sepia-extract-next-warning (pos &optional end)
 973   (catch 'foo
 974     (while (re-search-forward "^\\(.+\\) at \\(.+\\) line \\([0-9]+\\)\\.$"
 975                               end t)
 976       (unless (string= "(eval " (substring (match-string 2) 0 6))
 977         (throw 'foo (list (match-string 2)
 978                           (parse-integer (match-string 3))
 979                           (match-string 1)))))))
 980
 981 (defun sepia-goto-error-at (pos)
 982   "Visit the source of the error on line at POS (point if called
 983 interactively)."
 984   (interactive (list (point)))
 985   (ifa (sepia-extract-next-warning (my-bol-from pos) (my-eol-from pos))
 986        (destructuring-bind (file line msg) it
 987          (find-file file)
 988          (goto-line line)
 989          (message "%s" msg))
 990        (error "No error to find.")))
 991
 992 (defun sepia-display-errors (beg end)
 993   (interactive "r")
 994   (goto-char beg)
 995   (let ((msgs nil))
 996     (loop for w = (sepia-extract-next-warning (my-bol-from (point)) end)
 997        while w
 998        do (destructuring-bind (file line msg) w
 999             (push (format "%s:%d:%s\n" (abbreviate-file-name file) line msg)
1000                   msgs)))
1001     (erase-buffer)
1002     (goto-char (point-min))
1003     (mapcar #'insert msgs)
1004     (goto-char (point-min))
1005     (grep-mode)))
1006
1007 (defun to-perl (thing)
1008   "Convert elisp data structure to Perl."
1009   (cond
1010     ((null thing) "[]")
1011     ((symbolp thing)
1012      (let ((pname (substitute ?_ ?- (symbol-name thing)))
1013            (type (string-to-char (symbol-name thing))))
1014        (if (member type '(?% ?$ ?@ ?*))
1015            pname
1016            (concat "\\*" pname))))
1017     ((stringp thing) (format "\"%s\"" thing))
1018     ((integerp thing) (format "%d" thing))
1019     ((numberp thing) (format "%g" thing))
1020     ((and (consp thing) (not (consp (cdr thing))))
1021      (concat (to-perl (car thing)) " => " (to-perl (cdr thing))))
1022     ;; list
1023     ((or (not (consp (car thing)))
1024          (listp (cdar thing)))
1025      (concat "[" (mapconcat #'to-perl thing ", ") "]"))
1026     ;; hash table
1027     (t
1028      (concat "{" (mapconcat #'to-perl thing ", ") "}"))))
1029
1030 (defun comint-eval-lisp (str)
1031   (ignore-errors
1032     (when (and (> (length str) 4)
1033                (string= (substring str 0 3) "=> "))
1034       (message "would read `%s'"
1035                (car (read-from-string str 3 (- (length str) 3)))))))
1036
1037 (provide 'sepia)
1038 ;;; sepia.el ends here