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"))))))
  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   (add-hook 'cperl-mode-hook 'sepia-cperl-mode-hook)
 211   (when (boundp 'cperl-mode-map)
 212     (sepia-install-keys cperl-mode-map))
 213   (when (boundp 'perl-mode-map)
 214     (sepia-install-keys perl-mode-map))
 215   (sepia-interact))
 216
 217 (defun sepia-cperl-mode-hook ()
 218   (set (make-local-variable 'beginning-of-defun-function)
 219        'sepia-beginning-of-defun)
 220   (set (make-local-variable 'end-of-defun-function)
 221        'sepia-end-of-defun))
 222
 223 (defun define-xref-function (package name doc)
 224   "Define a lisp mirror for a low-level Sepia function."
 225   (let ((lisp-name (intern (format "xref-%s" name)))
 226         (pl-name (perl-name name package)))
 227     (fmakunbound lisp-name)
 228     (eval `(defun ,lisp-name (&rest args)
 229              ,doc
 230              (apply #'perl-call ,pl-name 'list-context args)))))
 231
 232 (defun define-modinfo-function (name &optional doc)
 233 "Define a lisp mirror for a function from Module::Info."
 234   (let ((name (intern (format "sepia-module-%s" name)))
 235         (pl-func (perl-name name))
 236         (full-doc (concat (or doc "") "
 237
 238 This function uses Module::Info, so it does not require that the
 239 module in question be loaded.")))
 240     (when (fboundp name) (fmakunbound name))
 241     (eval `(defun ,name (mod)
 242              ,full-doc
 243              (interactive (list (sepia-interactive-arg 'module)))
 244              (sepia-maybe-echo
 245               (perl-call "Sepia::module_info" 'scalar-context
 246                          mod ,pl-func))))))
 247
 248 (defun sepia-thing-at-point (what)
 249   "Like ``thing-at-point'', but hacked to avoid REPL prompt."
 250   (let ((th (thing-at-point what)))
 251     (and th (not (string-match "[ >]$" th)) th)))
 252
 253 (defvar sepia-sub-re "^\\s *sub\\s +\\(.+\\_>\\)")
 254
 255 (defun sepia-beginning-of-defun (&optional where)
 256   (interactive "d")
 257   (let ((here (point)))
 258     (beginning-of-line)
 259     (if (and (not (= here (point)))
 260              (looking-at sepia-sub-re))
 261       (point)
 262       (beginning-of-defun)
 263       (let* ((end (point))
 264              (beg (progn (previous-line 3) (point))))
 265         (goto-char end)
 266         (re-search-backward sepia-sub-re beg t)))))
 267
 268 (defun sepia-end-of-defun (&optional where)
 269   (interactive "d")
 270   (let ((here (point)))
 271     (beginning-of-defun)
 272     (let ((beg (point))
 273           (end-of-defun-function nil)
 274           (beginning-of-defun-function nil))
 275       (when (looking-at sepia-sub-re)
 276         (forward-line 1))
 277       (end-of-defun))
 278     (when (and (>= here (point))
 279                (re-search-forward sepia-sub-re nil t))
 280       (sepia-end-of-defun))
 281     (point)))
 282
 283 (defun sepia-defun-around-point (&optional where)
 284   (interactive "d")
 285   (unless where
 286     (setq where (point)))
 287   (save-excursion
 288     (and (sepia-beginning-of-defun where)
 289          (match-string-no-properties 1))))
 290
 291 (defun sepia-lexicals-at-point (&optional where)
 292   (interactive "d")
 293   (unless where
 294     (setq where (point)))
 295   (let ((subname (sepia-defun-around-point where))
 296         (mod (sepia-buffer-package)))
 297     (xref-lexicals (perl-name subname mod))))
 298
 299 (defun sepia-interactive-arg (&optional type)
 300 "Default argument for most Sepia functions.  TYPE is a symbol --
 301 either 'file to look for a file, or anything else to use the
 302 symbol at point."
 303   (let* ((default (case type
 304                     (file (or (thing-at-point 'file) (buffer-file-name)))
 305                     (t (sepia-thing-at-point 'symbol))))
 306          (text (capitalize (symbol-name type)))
 307          (choices (lambda (str &rest blah)
 308                     (let ((str (concat "^" str)))
 309                       (case type
 310                         (variable (xref-var-apropos str))
 311                         (function (xref-apropos str))
 312                         (module (xref-mod-apropos str))
 313                         (t nil)))))
 314          (ret (if sepia-use-completion
 315                   (completing-read (format "%s [%s]: " text default)
 316                                    choices nil nil nil 'sepia-history
 317                                    default)
 318                   (read-string (format "%s [%s]: " text default)
 319                                nil 'sepia-history default))))
 320     (push ret sepia-history)
 321     ret))
 322
 323 (defun sepia-interactive-module ()
 324 "Guess which module we should look things up in.  Prompting for a
 325 module all the time is a PITA, but I don't think this (choosing
 326 the current file's module) is a good alternative, either.  Best
 327 would be to choose the module based on what we know about the
 328 symbol at point."
 329   (let ((xs (xref-file-modules (buffer-file-name))))
 330     (if (= (length xs) 1)
 331         (car xs)
 332         nil)))
 333
 334 (defun sepia-maybe-echo (result)
 335   (when (interactive-p)
 336     (message "%s" result))
 337   result)
 338
 339 (defun sepia-module-find (mod)
 340 "Find the file defining module MOD."
 341   (interactive (list (sepia-interactive-arg 'module)))
 342   (let ((fn (or (sepia-module-file mod)
 343                 (car (xref-guess-module-file mod)))))
 344     (when fn
 345       (message "Module %s in %s." mod fn)
 346       (pop-to-buffer (find-file-noselect (expand-file-name fn))))))
 347
 348 (defmacro ifa (test then &rest else)
 349   `(let ((it ,test))
 350      (if it ,then ,@else)))
 351
 352 (defun sepia-show-locations (locs)
 353   (when locs
 354     (pop-to-buffer (get-buffer-create "*sepia-places*"))
 355     (erase-buffer)
 356     (dolist (loc (sort locs (lambda (a b)
 357                               (or (string< (car a) (car b))
 358                                   (and (string= (car a) (car b))
 359                                        (< (second a) (second b)))))))
 360       (destructuring-bind (file line name &rest blah) loc
 361         (let ((str (ifa (find-buffer-visiting file)
 362                         (with-current-buffer it
 363                           (ifa sepia-found-refiner
 364                                (funcall it line name)
 365                                (goto-line line))
 366                           (message "line for %s was %d, now %d" name line
 367                                    (line-number-at-pos))
 368                           (setq line (line-number-at-pos))
 369                           (let ((tmpstr
 370                                  (buffer-substring (my-bol-from (point))
 371                                                    (my-eol-from (point)))))
 372                             (if (> (length tmpstr) 60)
 373                                 (concat "\n    " tmpstr)
 374                                 tmpstr)))
 375                         "...")))
 376           (insert (format "%s:%d:%s\n" (abbreviate-file-name file) line str)))))
 377     (grep-mode)
 378     (goto-char (point-min))))
 379
 380 (defun sepia-filter-by-module (x)
 381   "Filter to limit hits by module only."
 382   (when (or (not module) (string= module (fourth x)))
 383     (list x)))
 384
 385 (defun sepia-filter-by-all (x)
 386   "Filter to limit hits by module and file."
 387   (when (and (or (not module) (string= module (fourth x)))
 388              (or (not file) (string= file (first x))))
 389     (list x)))
 390
 391 (defmacro define-sepia-query (name doc &optional gen test prompt)
 392   `(defun ,name (ident &optional module file line display-p)
 393      ,(concat doc "
 394
 395 With prefix arg, list occurences in a ``grep-mode'' buffer.
 396 Without, place the occurrences on ``sepia-found'', so that
 397 calling ``sepia-next'' will cycle through them.
 398
 399 Depending on the query, MODULE, FILE, and LINE may be used to
 400 narrow the results, as long as doing so leaves some matches.
 401 When called interactively, they are taken from the current
 402 buffer.
 403 ")
 404      (interactive (list (sepia-interactive-arg ,(or prompt ''function))
 405                         (sepia-interactive-module)
 406                         (buffer-file-name)
 407                         (line-number-at-pos (point))
 408                         current-prefix-arg
 409                         ))
 410      (let ((ret
 411             ,(if test
 412                  `(let ((tmp (,gen ident module file line)))
 413                     (or (mapcan #',test tmp) tmp))
 414                  `(,gen ident module file line))))
 415        ;; Always clear out the last found ring, because it's confusing
 416        ;; otherwise.
 417        (sepia-set-found nil ',(or prompt 'function))
 418        (if display-p
 419            (sepia-show-locations ret)
 420            (sepia-set-found ret ',(or prompt 'function))
 421            (sepia-next)))))
 422
 423 (defun sepia-location (name &optional jump-to)
 424   (interactive (list (or (thing-at-point 'symbol)
 425                          (completing-read "Function: " 'xref-completions))
 426                      t))
 427   (let* ((fl (or (car (xref-location name))
 428                  (car (remove-if #'null
 429                                  (apply #'xref-location (xref-apropos name)))))))
 430     (when (and fl (string-match "^(eval " (car fl)))
 431       (message "Can't find definition of %s in %s." name (car fl))
 432       (setq fl nil))
 433     (if jump-to
 434         (if fl (progn
 435                  (sepia-set-found (list fl) 'function)
 436                  (sepia-next))
 437             (message "No definition for %s." name))
 438         fl)))
 439
 440 ;;;###autoload
 441 (defun sepia-dwim (&optional display-p)
 442     "Try to DWIM:
 443 * Find all definitions, if thing-at-point is a function
 444 * Find all uses, if thing-at-point is a variable
 445 * Find all definitions, if thing-at-point is a module
 446 * Prompt otherwise
 447 "
 448     (interactive "P")
 449     (multiple-value-bind (type obj) (sepia-ident-at-point)
 450       (setq type (if type (string type) ""))
 451       (message "%s %S" type obj)
 452       (if type
 453           (progn
 454 ;;          (sepia-set-found nil 'variable)
 455             (let ((ret (if type
 456                          (function (list (sepia-location raw)))
 457                          (variable (xref-var-uses raw))
 458                          (module `((,(car (xref-mod-files mod)) 1 nil nil))))))
 459               (if display-p
 460                   (sepia-show-locations ret)
 461                   (sepia-set-found ret type)
 462                   (sepia-next))))
 463           (call-interactively 'sepia-defs))))
 464
 465 (define-sepia-query sepia-defs
 466     "Find all definitions of sub."
 467   xref-apropos
 468   xref-location)
 469
 470 (define-sepia-query sepia-callers
 471     "Find callers of FUNC."
 472   xref-callers
 473   xref-location)
 474
 475 (define-sepia-query sepia-callees
 476     "Find a sub's callees."
 477   xref-callees
 478   xref-location)
 479
 480 (define-sepia-query sepia-var-defs
 481     "Find a var's definitions."
 482   xref-var-defs
 483   (lambda (x) (setf (third x) ident) (list x))
 484   'variable)
 485
 486 (define-sepia-query sepia-var-uses
 487     "Find a var's uses."
 488   xref-var-uses
 489   (lambda (x) (setf (third x) ident) (list x))
 490   'variable)
 491
 492 (define-sepia-query sepia-var-assigns
 493     "Find/list assignments to a variable."
 494   xref-var-assigns
 495   (lambda (x) (setf (third x) ident) (list x))
 496   'variable)
 497
 498 (define-sepia-query sepia-module-describe
 499     "Find all subroutines in a package."
 500   xref-mod-subs
 501   nil
 502   'module)
 503
 504 (defalias 'sepia-package-defs 'sepia-module-describe)
 505
 506 (define-sepia-query sepia-apropos
 507     "Find/list subroutines matching regexp."
 508   (lambda (name &rest blah) (xref-apropos name 1))
 509   xref-location
 510   'function)
 511
 512 (define-sepia-query sepia-var-apropos
 513     "Find/list variables matching regexp."
 514   xref-var-apropos
 515   xref-var-defs
 516   'variable)
 517
 518 (defun sepia-rebuild ()
 519   "Rebuild the Xref database."
 520   (interactive)
 521   (xref-rebuild))
 522
 523 ;;;###autoload
 524 (defun sepia-load-file (file &optional rebuild-p collect-warnings)
 525   "Reload a file.  With REBUILD-P (or a prefix argument when
 526 called interactively), also rebuild the xref database."
 527   (interactive (progn (save-buffer)
 528                       (list (buffer-file-name)
 529                             prefix-arg
 530                ;;              (format "*%s errors*" (buffer-file-name))
 531                             nil
 532                             )))
 533   (message
 534    "sepia: %s returned %s"
 535    (abbreviate-file-name file)
 536    (perl-eval
 537 ;;     (if collect-warnings
 538 ;;         (format "{ local $SIG{__WARN__} = Sepia::emacs_warner('%s'); do '%s' }"
 539 ;;                 collect-warnings file)
 540         (format "do '%s' ? 1 : $@" file)
 541     'scalar-context))
 542   (when collect-warnings
 543     (with-current-buffer (get-buffer-create collect-warnings)
 544       (sepia-display-errors (point-min) (point-max))
 545       (if (> (buffer-size) 0)
 546           (pop-to-buffer (current-buffer))
 547           (kill-buffer (current-buffer)))))
 548   (when rebuild-p
 549     (xref-rebuild)))
 550
 551 (defvar sepia-found)
 552 (defvar sepia-found-head)
 553 (defvar sepia-found-refiner)
 554 (defvar sepia-history nil)
 555
 556 (defun sepia-set-found (list &optional type)
 557   (setq list
 558         (remove-if (lambda (x)
 559                      (and (not (car x)) (string= (fourth x) "main")))
 560                    list))
 561   (setq sepia-found list
 562         sepia-found-head list)
 563   (setq sepia-found-refiner (sepia-refiner type)))
 564
 565 (defun sepia-refiner (type)
 566   (case type
 567     (function
 568      (lambda (line ident)
 569       (let ((sub-re (concat "^\\s *sub\\s +.*" ident "\\_>")))
 570         ;; Test this because sometimes we get lucky and get the line
 571         ;; just right, in which case beginning-of-defun goes to the
 572         ;; previous defun.
 573         (unless (looking-at sub-re)
 574           (or (and line
 575                    (progn
 576                      (goto-line line)
 577                      (beginning-of-defun)
 578                      (looking-at sub-re)))
 579               (progn (goto-char (point-min))
 580                      (re-search-forward sub-re nil t)))
 581           (beginning-of-line)))))
 582     ;; Old version -- this may actually work better if
 583     ;; beginning-of-defun goes flaky on us.
 584 ;;         (or (re-search-backward sub-re
 585 ;;                                 (my-bol-from (point) -20) t)
 586 ;;             (re-search-forward sub-re
 587 ;;                                (my-bol-from (point) 10) t))
 588 ;;         (beginning-of-line)
 589     (variable
 590      (lambda (line ident)
 591        (let ((var-re (concat "\\_<" ident "\\_>")))
 592          (cond
 593            (line (goto-line line)
 594                  (or (re-search-backward var-re (my-bol-from (point) -5) t)
 595                      (re-search-forward var-re (my-bol-from (point) 5) t)))
 596            (t (goto-char (point-min))
 597               (re-search-forward var-re nil t))))))
 598     (t (lambda (line ident) (and line (goto-line line))))))
 599
 600 (defun sepia-next ()
 601 "Go to the next thing (e.g. def, use) found by sepia."
 602   (interactive)
 603   (if sepia-found
 604       (destructuring-bind (file line short &optional mod &rest blah)
 605           (car sepia-found)
 606         (unless file
 607           (setq file (and mod (sepia-module-file mod)))
 608           (if file
 609               (setf (caar sepia-found) file)
 610               (error "No file for %s." (car sepia-found))))
 611         (message "%s at %s:%s" short file line)
 612         (when (file-exists-p file)
 613           (find-file (or file (car (xref-mod-files mod))))
 614           (when sepia-found-refiner
 615             (funcall sepia-found-refiner line short))
 616           (beginning-of-line)
 617           (recenter)
 618           (setq sepia-found (or (cdr sepia-found)
 619                                 (progn
 620                                   (message "sepia: no more defs.")
 621                                   sepia-found-head)))))
 622       (message "No more definitions.")))
 623
 624 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 625 ;; Completion
 626
 627 (defun sepia-ident-at-point ()
 628   (save-excursion
 629     (when (looking-at "[%$@*&]")
 630       (forward-char 1))
 631     (let* ((beg (progn
 632                  (when (re-search-backward "[^A-Za-z_0-9:]" nil 'mu)
 633                    (forward-char 1))
 634                  (point)))
 635           (sigil (if (= beg (point-min))
 636                      nil
 637                      (char-before (point))))
 638           (end (progn
 639                  (when (re-search-forward "[^A-Za-z_0-9:]" nil 'mu)
 640                    (forward-char -1))
 641                  (point))))
 642       (list (when (member sigil '(?$ ?@ ?% ?* ?&)) sigil)
 643             (buffer-substring-no-properties beg end)))))
 644
 645 (defun sepia-function-at-point ()
 646   (condition-case nil
 647       (save-excursion
 648         (let ((pt (point))
 649               bof)
 650           (sepia-beginning-of-defun)
 651           (setq bof (point))
 652           (goto-char pt)
 653           (sepia-end-of-defun)
 654           (when (and (>= pt bof) (< pt (point)))
 655             (goto-char bof)
 656             (looking-at "\\s *sub\\s +")
 657             (forward-char (length (match-string 0)))
 658             (concat (or (sepia-buffer-package) "")
 659                     "::"
 660                     (cadr (sepia-ident-at-point))))))
 661     (error nil)))
 662
 663 (defun sepia-complete-symbol ()
 664   "Try to complete the word at point, either as a global variable if it
 665 has a sigil (sorry, no lexicals), a module, or a function.  The
 666 function currently ignores module qualifiers, which may be
 667 annoying in larger programs.
 668
 669 The function is intended to be bound to \\M-TAB, like
 670 ``lisp-complete-symbol''."
 671   (interactive)
 672   (multiple-value-bind (type name) (sepia-ident-at-point)
 673     (let ((len  (+ (if type 1 0) (length name)))
 674           (completions (xref-completions
 675                         (if (string-match ":" name)
 676                             name
 677                             (concat (sepia-buffer-package) "::" name))
 678                         (case type
 679                           (?$ "SCALAR")
 680                           (?@ "ARRAY")
 681                           (?% "HASH")
 682                           (?& "CODE")
 683                           (?* "IO")
 684                           (t ""))
 685                         (sepia-function-at-point))))
 686       (case (length completions)
 687         (0 (message "No completions for %s." name) nil)
 688         (1 ;; (delete-ident-at-point)
 689          (delete-region (- (point) len) (point))
 690          (insert (if type (string type) "") (car completions))
 691          t)
 692         (t (let ((old name)
 693                  (new (try-completion "" completions)))
 694              (if (string= new old)
 695                  (with-output-to-temp-buffer "*Completions*"
 696                    (display-completion-list completions))
 697                  (delete-region (- (point) len) (point))
 698                  (insert (if type (string type) "") new)))
 699            t)))
 700     ))
 701
 702 (defun sepia-indent-or-complete ()
 703 "Indent the current line and, if indentation doesn't move point,
 704 complete the symbol around point.  This function is intended to
 705 be bound to TAB."
 706   (interactive)
 707   (let ((pos (point)))
 708     (cperl-indent-command)
 709     (when (and (= pos (point))
 710                (eq last-command 'sepia-indent-or-complete))
 711       (sepia-complete-symbol))))
 712
 713 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 714 ;;; scratchpad code
 715
 716 ;;;###autoload
 717 (defun sepia-scratch ()
 718 "Create a buffer to interact with a Perl interpreter.  The buffer
 719 is placed in cperl-mode; calling ``sepia-scratch-send-line'' will
 720 evaluate the current line and display the result."
 721   (interactive)
 722   (switch-to-buffer (get-buffer-create "*perl-scratch*"))
 723   (cperl-mode)
 724   (local-set-key "\C-j" 'sepia-scratch-send-line))
 725
 726 (defun sepia-scratch-send-line (&optional scalarp)
 727 "Send the current line to perl, and display the result."
 728   (interactive "P")
 729   (insert
 730    (sepia-eval (concat "do{"
 731                        (buffer-substring (my-bol-from (point))
 732                                          (my-eol-from (point)))
 733                        "}"))))
 734
 735 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 736 ;; Miscellany
 737
 738 (defun my-perl-frob-region (pre post beg end replace-p)
 739   (let* ((exp (concat pre "\""
 740                       (shell-quote-argument (buffer-substring beg end))
 741                       "\"" post))
 742          (new-str (format "%s" (perl-eval exp 'scalar-context))))
 743     (if replace-p
 744         (progn (delete-region beg end)
 745                (goto-char beg)
 746                (insert new-str))
 747         (message new-str))))
 748
 749 (defun my-eol-from (pt &optional n)
 750   (save-excursion
 751     (goto-char pt)
 752     (end-of-line n)
 753     (point)))
 754
 755 (defun my-bol-from (pt &optional n)
 756   (save-excursion
 757     (goto-char pt)
 758     (beginning-of-line n)
 759     (point)))
 760
 761 (defun perl-pe-region (expr beg end &optional replace-p)
 762 "Do the equivalent of perl -pe on region (i.e. evaluate an
 763 expression on each line of region).  With prefix arg, replace the
 764 region with the result."
 765   (interactive "MExpression: \nr\nP")
 766   (my-perl-frob-region
 767    "{ my $ret='';my $region = "
 768    (concat "; for (split /\n/, $region) { do { " expr
 769            ";}; $ret.=\"$_\\n\"}; $ret}")
 770    (my-bol-from beg) (my-eol-from end) replace-p))
 771
 772 (defun perl-ne-region (expr beg end &optional replace-p)
 773 "Do the moral equivalent of perl -ne on region (i.e. evaluate an
 774 expression on each line of region).  With prefix arg, replace the
 775 region with the result."
 776   (interactive "MExpression:\nr\nP")
 777   (my-perl-frob-region
 778    "{ my $ret='';my $region = "
 779    (concat "; for (split /\n/, $region) { $ret .= do { " expr
 780            ";} }; $ret}")
 781    (my-bol-from beg) (my-eol-from end) replace-p))
 782
 783 (defun perl-ize-region (expr beg end &optional replace-p)
 784 "Evaluate a Perl expression on the region as a whole.  With
 785 prefix arg, replace the region with the result."
 786   (interactive "MExpression:\nr\nP")
 787   (my-perl-frob-region "{ local $_ = "
 788                        (concat "; do { " expr ";}; $_ }")
 789                        beg end replace-p))
 790
 791 (defun sepia-guess-package (sub &optional file)
 792   "Guess which package SUB is defined in."
 793   (let ((defs (xref-location (xref-apropos sub))))
 794     (or (and (= (length defs) 1)
 795              (or (not file) (equal (caar defs) file))
 796              (fourth (car defs)))
 797         (and file
 798              (fourth (find-if (lambda (x) (equal (car x) file)) defs)))
 799         (car (xref-file-modules file))
 800         (sepia-buffer-package))))
 801
 802 ;;;###autoload
 803 (defun sepia-eval-defun ()
 804   "Re-evaluate the current sub in the appropriate package, and
 805 rebuild its Xrefs."
 806   (interactive)
 807   (save-excursion
 808     (let* ((pt (point))
 809            (end (progn (end-of-defun) (point)))
 810            (beg (progn (sepia-beginning-of-defun pt) (point))))
 811       (goto-char beg)
 812       (when (looking-at "^sub\\s +\\(.+\\_>\\)")
 813         (let* ((sub (match-string 1))
 814                (sepia-eval-package
 815                 (sepia-guess-package sub (buffer-file-name)))
 816                (body (buffer-substring-no-properties beg end))
 817                (sepia-eval-file (buffer-file-name))
 818                (sepia-eval-line (line-number-at-pos beg)))
 819           (sepia-eval (if sepia-eval-defun-include-decls
 820                           (concat
 821                            (apply #'concat (xref-mod-decls sepia-eval-package))
 822                            body)
 823                           body))
 824           (xref-redefined sub sepia-eval-package)
 825           (message "Defined %s" sub))))))
 826
 827 (defun sepia-extract-def (file line obj mod)
 828   (with-current-buffer (find-file-noselect (expand-file-name file))
 829     (save-excursion
 830       (funcall (sepia-refiner 'function) line obj)
 831       (beginning-of-line)
 832       (when (looking-at (concat "^\\s *sub\\_>.*\\_<" obj "\\_>"))
 833         (buffer-substring (point)
 834                           (progn (end-of-defun) (point)))))))
 835
 836 (defun sepia-eval-no-run (string &optional discard collect-warnings)
 837   (condition-case err
 838       (sepia-eval
 839        (concat "BEGIN { use B; B::minus_c(); $^C=1; } { "
 840                string
 841                "} BEGIN { die \"ok\\n\" }")
 842        discard collect-warnings)
 843     (perl-error (if (string-match "^ok\n" (cadr err))
 844                     nil
 845                     (cadr err)))
 846     (error err)))
 847
 848 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 849 ;; REPL
 850
 851 (defvar sepia-eval-package "main"
 852   "Package in which ``sepia-eval'' evaluates perl expressions.")
 853 (defvar sepia-eval-file nil
 854   "File in which ``sepia-eval'' evaluates perl expressions.")
 855 (defvar sepia-eval-line nil
 856   "Line at which ``sepia-eval'' evaluates perl expressions.")
 857
 858 (defun sepia-set-eval-package (new-package)
 859   (setq sepia-eval-package new-package))
 860
 861 (defun sepia-get-eval-package ()
 862   sepia-eval-package)
 863
 864 (defun sepia-eval (string &optional discard collect-warnings)
 865   "Evaluate STRING as Perl code, returning the pretty-printed
 866 value of the last expression.  If SOURCE-FILE is given, use this
 867 as the file containing the code to be evaluated.  XXX: this is
 868 the only function that requires EPL (the rest can use Pmacs)."
 869   (perl-eval-raw
 870    (concat
 871  "{ package " (or sepia-eval-package "main") ";"
 872  (if sepia-eval-file (concat "$Sepia::Xref::file = \"" sepia-eval-file "\";")
 873      "")
 874  (if sepia-eval-line (format "$Sepia::Xref::line = %d;\n#line %d\n"
 875                              sepia-eval-line sepia-eval-line)
 876      "")
 877  (if discard
 878      (concat string "; '' }\n")
 879      (concat
 880       "require Data::Dumper;"
 881 ;;       "local $Data::Dumper::Indent=0;"
 882       "local $Data::Dumper::Deparse=1;"
 883       (if sepia-eval-line (format "\n#line %d\n" sepia-eval-line) "")
 884       "my $result = Data::Dumper::Dumper([do { " string "}]);"
 885       "$result =~ s/^.*?=\\s*\\[//; $result =~ s/\\];$//;$result}")))))
 886
 887 ;;;###autoload
 888 (defun sepia-interact ()
 889 "Start or switch to a perl interaction buffer."
 890   (interactive)
 891   (pop-to-buffer (get-buffer "*perl-interaction*")))
 892
 893 (defun sepia-set-cwd (dir)
 894   (perl-call "Cwd::chdir" dir))
 895
 896 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 897 ;; Doc-scanning
 898
 899 (defvar sepia-doc-map (make-hash-table :test #'equal))
 900 (defvar sepia-var-doc-map (make-hash-table :test #'equal))
 901 (defvar sepia-module-doc-map (make-hash-table :test #'equal))
 902
 903 (defun sepia-doc-scan-buffer ()
 904   (save-excursion
 905     (ignore-errors
 906     (goto-char (point-min))
 907     (loop while (re-search-forward
 908                  "^=\\(item\\|head2\\)\\s +\\([%$&@A-Za-z_].*\\)" nil t)
 909        if (let* ((s1 (match-string 2))
 910                  (s2 (let ((case-fold-search nil))
 911                        (replace-regexp-in-string
 912                         "[A-Z]<\\([^>]+\\)>"
 913                         (lambda (x) (match-string 1 s1)) s1)))
 914                  (longdoc
 915                   (let ((beg (progn (forward-line 2) (point)))
 916                         (end (1- (re-search-forward "^=" nil t))))
 917                     (forward-line -1)
 918                     (goto-char beg)
 919                     (if (re-search-forward "^\\(.+\\)$" end t)
 920                         (concat s2 ": "
 921                                 (substring-no-properties
 922                                  (match-string 1)
 923                                  0 (position ?. (match-string 1))))
 924                         s2))))
 925             (cond
 926               ;; e.g. "C<foo(BLAH)>" or "$x = $y->foo()"
 927               ((string-match "\\(\\sw+\\)\\s *\\($\\|(\\)" s2)
 928                (list 'function (match-string-no-properties 1 s2)
 929                      (or (and (equal s2 (match-string 1 s2)) longdoc) s2)))
 930               ;; e.g. "$x -- this is x" (note: this has to come second)
 931               ((string-match "^[%$@]\\([^( ]+\\)" s2)
 932                (list 'variable (match-string-no-properties 1 s2) longdoc))))
 933        collect it))))
 934
 935 (defun sepia-buffer-package ()
 936   (save-excursion
 937     (goto-char (point-min))
 938     (or (and (re-search-forward "^\\s *package\\s +\\([^ ;]+\\)" nil t)
 939              (match-string-no-properties 1))
 940         "main")))
 941
 942 (defun sepia-doc-update ()
 943 "Update documentation for a file.  This documentation, taken from
 944 \"=item\" entries in the POD, is used for eldoc feedback."
 945   (interactive)
 946   (let ((pack (ifa (or
 947                     (car (xref-file-modules (buffer-file-name)))
 948                     (sepia-buffer-package))
 949                    (concat it "::")
 950                    "")))
 951     (dolist (x (sepia-doc-scan-buffer))
 952       (let ((map (ecase (car x)
 953                    (function sepia-doc-map)
 954                    (variable sepia-var-doc-map))))
 955         (puthash (second x) (third x) map)
 956         (puthash (concat pack (second x)) (third x) map)))))
 957
 958 (defun sepia-symbol-info ()
 959 "Eldoc function for Sepia-mode.  Looks in ``sepia-doc-map'' and
 960 ``sepia-var-doc-map'', then tries calling
 961 ``cperl-describe-perl-symbol''."
 962   (save-excursion
 963     (multiple-value-bind (obj mod type) (sepia-ident-at-point)
 964       (or (when type
 965             (let ((map (ecase type
 966                          (function sepia-doc-map)
 967                          (variable sepia-var-doc-map)
 968                          (module sepia-module-doc-map))))
 969               (if mod
 970                   (gethash mod map)
 971                   (gethash obj map))))
 972           (when obj
 973             ;; Loathe cperl a bit.
 974             (when (consp obj)
 975               (setq obj (car obj)))
 976             (flet ((message (&rest blah) (apply #'format blah)))
 977               (let* ((cperl-message-on-help-error nil)
 978                      (hlp (car (cperl-describe-perl-symbol obj))))
 979                 (when hlp
 980                   ;; cperl's docstrings are too long.
 981                   (setq hlp (replace-regexp-in-string "\\s \\{2,\\}" "  " hlp))
 982                   (if (> (length hlp) 75)
 983                       (concat (substring hlp 0 72) "...")
 984                       hlp)))))
 985           ""))))
 986
 987 (defun sepia-install-eldoc ()
 988 "Install Sepia hooks for eldoc support (probably requires Emacs >= 21.3)."
 989   (interactive)
 990   (set (make-variable-buffer-local
 991         'eldoc-print-current-symbol-info-function)
 992        #'sepia-symbol-info)
 993   (if cperl-lazy-installed (cperl-lazy-unstall))
 994   (eldoc-mode 1)
 995   (setq eldoc-idle-delay 1.0))
 996
 997 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 998 ;; Error jump:
 999
1000 (defun sepia-extract-next-warning (pos &optional end)
1001   (catch 'foo
1002     (while (re-search-forward "^\\(.+\\) at \\(.+\\) line \\([0-9]+\\)\\.$"
1003                               end t)
1004       (unless (string= "(eval " (substring (match-string 2) 0 6))
1005         (throw 'foo (list (match-string 2)
1006                           (parse-integer (match-string 3))
1007                           (match-string 1)))))))
1008
1009 (defun sepia-goto-error-at (pos)
1010   "Visit the source of the error on line at POS (point if called
1011 interactively)."
1012   (interactive (list (point)))
1013   (ifa (sepia-extract-next-warning (my-bol-from pos) (my-eol-from pos))
1014        (destructuring-bind (file line msg) it
1015          (find-file file)
1016          (goto-line line)
1017          (message "%s" msg))
1018        (error "No error to find.")))
1019
1020 (defun sepia-display-errors (beg end)
1021   (interactive "r")
1022   (goto-char beg)
1023   (let ((msgs nil))
1024     (loop for w = (sepia-extract-next-warning (my-bol-from (point)) end)
1025        while w
1026        do (destructuring-bind (file line msg) w
1027             (push (format "%s:%d:%s\n" (abbreviate-file-name file) line msg)
1028                   msgs)))
1029     (erase-buffer)
1030     (goto-char (point-min))
1031     (mapcar #'insert msgs)
1032     (goto-char (point-min))
1033     (grep-mode)))
1034
1035 (defun to-perl (thing)
1036   "Convert elisp data structure to Perl."
1037   (cond
1038     ((null thing) "[]")
1039     ((symbolp thing)
1040      (let ((pname (substitute ?_ ?- (symbol-name thing)))
1041            (type (string-to-char (symbol-name thing))))
1042        (if (member type '(?% ?$ ?@ ?*))
1043            pname
1044            (concat "\\*" pname))))
1045     ((stringp thing) (format "\"%s\"" thing))
1046     ((integerp thing) (format "%d" thing))
1047     ((numberp thing) (format "%g" thing))
1048     ((and (consp thing) (not (consp (cdr thing))))
1049      (concat (to-perl (car thing)) " => " (to-perl (cdr thing))))
1050     ;; list
1051     ((or (not (consp (car thing)))
1052          (listp (cdar thing)))
1053      (concat "[" (mapconcat #'to-perl thing ", ") "]"))
1054     ;; hash table
1055     (t
1056      (concat "{" (mapconcat #'to-perl thing ", ") "}"))))
1057
1058 (defun comint-eval-lisp (str)
1059   (ignore-errors
1060     (when (and (> (length str) 4)
1061                (string= (substring str 0 3) "=> "))
1062       (message "would read `%s'"
1063                (car (read-from-string str 3 (- (length str) 3)))))))
1064
1065 (provide 'sepia)
1066 ;;; sepia.el ends here