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-2008 Sean O'Rourke.  All rights reserved, some
   5 ;; wrongs reversed.  This code is distributed under the same terms as
   6 ;; Perl itself.
   7
   8 ;;; Commentary:
   9
  10 ;; Sepia is a set of tools for Perl development in Emacs.  Its goal is
  11 ;; to extend CPerl mode with two contributions: fast code navigation
  12 ;; and interactive development.  It is inspired by Emacs' current
  13 ;; support for a number of other languages, including Lisp, Python,
  14 ;; Ruby, and Emacs Lisp.
  15 ;;
  16 ;; See sepia.texi, which comes with the distribution.
  17
  18 ;;; Code:
  19
  20 (require 'cperl-mode)
  21 (require 'gud)
  22 (require 'cl)
  23 ;; try optional modules, but don't bitch if we fail:
  24 (ignore-errors (require 'sepia-w3m))
  25 (ignore-errors (require 'sepia-tree))
  26 (ignore-errors (require 'sepia-ido))
  27
  28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29 ;;; Comint communication
  30
  31 (defvar sepia-perl5lib nil
  32 "* List of extra PERL5LIB directories for `sepia-repl'.")
  33
  34 (defvar sepia-program-name "perl"
  35 "* Perl program name.")
  36
  37 (defvar sepia-view-pod-function
  38   (if (featurep 'w3m) 'sepia-w3m-view-pod 'sepia-perldoc-buffer)
  39 "* Function to view current buffer's documentation.
  40
  41 Useful values include `sepia-w3m-view-pod' and `sepia-perldoc-buffer'.")
  42
  43 (defvar sepia-module-list-function
  44   (if (featurep 'w3m) 'w3m-find-file 'browse-url-of-buffer)
  45 "* Function to view a list of installed modules.
  46
  47 Useful values include `w3m-find-file' and `browse-url-of-buffer'.")
  48
  49 (defvar sepia-complete-methods t
  50 "* Non-nil if Sepia should try to complete methods for \"$x->\".
  51
  52 NOTE: this feature can be problematic, since it evaluates the
  53 object in order to find its type.  Currently completion is only
  54 attempted for objects that are simple scalars.")
  55
  56 (defvar sepia-indent-expand-abbrev t
  57 "* If non-NIL, `sepia-indent-or-complete' tries `expand-abbrev'.")
  58
  59 (defvar sepia-use-completion t
  60   "* Use completion based on Xref database.
  61
  62 Turning this off may speed up some operations, if you don't mind
  63 losing completion.")
  64
  65 (defvar sepia-eval-defun-include-decls t
  66   "* Generate and use a declaration list for `sepia-eval-defun'.
  67 Without this, code often will not parse; with it, evaluation may
  68 be a bit less responsive.  Note that since this only includes
  69 subs from the evaluation package, it may not always work.")
  70
  71 (defvar sepia-prefix-key "\M-."
  72   "* Prefix for functions in `sepia-keymap'.")
  73
  74 ;;; User options end here.
  75
  76 (defvar sepia-process nil
  77 "The perl process with which we're interacting.")
  78 (defvar sepia-output nil
  79 "Current perl output for a response to `sepia-eval-raw', appended
  80 to by `perl-collect-output'.")
  81 (defvar sepia-passive-output ""
  82 "Current perl output for miscellaneous user interaction, used to
  83 look for \";;;###\" lisp evaluation markers.")
  84
  85 (defvar sepia-perl-builtins nil
  86 "List of Perl builtins for completion.")
  87
  88 (defun sepia-collect-output (string)
  89 "Collect perl output for `sepia-eval-raw' into sepia-output."
  90   (setq sepia-output (concat sepia-output string))
  91   "")
  92
  93 (defun sepia-eval-raw (str)
  94   "Evaluate perl code STR, returning a pair (RESULT-STRING . OUTPUT)."
  95   (sepia-ensure-process)
  96   (let (ocpof)
  97     (unwind-protect
  98          (let ((sepia-output "")
  99                (start 0))
 100            (with-current-buffer (process-buffer sepia-process)
 101              (setq ocpof comint-preoutput-filter-functions
 102                    comint-preoutput-filter-functions
 103                    '(sepia-collect-output)))
 104            (setq str (concat "local $Sepia::STOPDIE=0;"
 105                              "local $Sepia::STOPWARN=0;"
 106                              "{ package " (sepia-buffer-package) ";"
 107                              str " }\n"))
 108            (comint-send-string sepia-process
 109                                (concat (format "<<%d\n" (length str)) str))
 110            (while (not (and sepia-output
 111                             (string-match "> $" sepia-output)))
 112              (accept-process-output sepia-process))
 113            (if (string-match "^;;;[0-9]+\n" sepia-output)
 114                (cons
 115                 (let* ((x (read-from-string sepia-output
 116                                             (+ (match-beginning 0) 3)))
 117                        (len (car x))
 118                        (pos (cdr x)))
 119                   (prog1 (substring sepia-output (1+ pos) (+ len pos 1))
 120                     (setq start (+ pos len 1))))
 121                 (and (string-match ";;;[0-9]+\n" sepia-output start)
 122                      (let* ((x (read-from-string
 123                                 sepia-output
 124                                 (+ (match-beginning 0) 3)))
 125                             (len (car x))
 126                             (pos (cdr x)))
 127                        (substring sepia-output (1+ pos) (+ len pos 1)))))
 128                (cons sepia-output nil)))
 129       (with-current-buffer (process-buffer sepia-process)
 130         (setq comint-preoutput-filter-functions ocpof)))))
 131
 132 (defun sepia-eval (str &optional context detailed)
 133 "Evaluate STR in CONTEXT (void by default), and return its result
 134 as a Lisp object.  If DETAILED is specified, return a
 135 pair (RESULT . OUTPUT)."
 136   (let* ((tmp (sepia-eval-raw
 137                (case context
 138                  (list-context
 139                   (concat "Sepia::tolisp([" str "])"))
 140                  (scalar-context
 141                   (concat "Sepia::tolisp(scalar(" str "))"))
 142                  (t (concat str ";1")))))
 143          (res (car tmp))
 144          (errs (cdr tmp)))
 145     (setq res (if context
 146                   (if (string= res "") "" (car (read-from-string res)))
 147                   1))
 148     (if detailed
 149         (cons res errs)
 150         res)))
 151
 152 (defun sepia-call (fn context &rest args)
 153 "Call perl function FN in CONTEXT with arguments ARGS, returning
 154 its result as a Lisp value."
 155   (sepia-eval (concat fn "(" (mapconcat #'sepia-lisp-to-perl args ", ") ")")
 156               context))
 157
 158 (defun sepia-watch-for-eval (string)
 159 "Monitor inferior Perl output looking for Lisp evaluation
 160 requests.  The format for these requests is
 161 \"\\n;;;###LENGTH\\nDATA\".  Only one such request can come from
 162 each inferior Perl prompt."
 163   (setq sepia-passive-output (concat sepia-passive-output string))
 164   (cond
 165     ((string-match "^;;;###[0-9]+" sepia-passive-output)
 166      (if (string-match "^;;;###\\([0-9]+\\)\n\\(?:.\\|\n\\)*\n\\(.*> \\)"
 167                          sepia-passive-output)
 168        (let* ((len (car (read-from-string
 169                          (match-string 1 sepia-passive-output))))
 170               (pos (1+ (match-end 1)))
 171               (res (ignore-errors (eval (car (read-from-string
 172                                               sepia-passive-output pos
 173                                               (+ pos len)))))))
 174          (message "%s => %s"
 175                   (substring sepia-passive-output pos (+ pos len)) res)
 176          (goto-char (point-max))
 177          (insert (substring sepia-passive-output (+ 1 pos len)))
 178          (set-marker (process-mark (get-buffer-process (current-buffer)))
 179                      (point))
 180          (setq sepia-passive-output ""))
 181        ""))
 182     (t (setq sepia-passive-output "") string)))
 183
 184
 185 (defvar sepia-metapoint-map
 186   (let ((map (make-sparse-keymap)))
 187     (when (featurep 'ido)
 188       (define-key map "j" 'sepia-jump-to-symbol))
 189     (dolist (kv '(("c" . sepia-callers)
 190                   ("C" . sepia-callees)
 191                   ("a" . sepia-apropos)
 192                   ("A" . sepia-var-apropos)
 193                   ("v" . sepia-var-uses)
 194                   ("V" . sepia-var-defs)
 195                   ;;              ("V" . sepia-var-assigns)
 196                   ("\M-." . sepia-dwim)
 197                   ;; ("\M-." . sepia-location)
 198                   ("l" . sepia-location)
 199                   ("f" . sepia-defs)
 200                   ("r" . sepia-rebuild)
 201                   ("m" . sepia-module-find)
 202                   ("n" . sepia-next)
 203                   ("t" . find-tag)
 204                   ("d" . sepia-perldoc-this)))
 205       (define-key map (car kv) (cdr kv)))
 206     map)
 207   "Keymap for Sepia functions.  This is just an example of how you
 208 might want to bind your keys, which works best when bound to
 209 `\\M-.'.")
 210
 211 (defvar sepia-shared-map
 212   (let ((map (make-sparse-keymap)))
 213     (define-key map sepia-prefix-key sepia-metapoint-map)
 214     (define-key map "\M-," 'sepia-next)
 215     (define-key map "\C-\M-x" 'sepia-eval-defun)
 216     (define-key map "\C-c\C-l" 'sepia-load-file)
 217     (define-key map "\C-c\C-p" 'sepia-view-pod) ;was cperl-pod-spell
 218     (define-key map "\C-c\C-d" 'cperl-perldoc)
 219     (define-key map "\C-c\C-r" 'sepia-repl)
 220     (define-key map "\C-c\C-s" 'sepia-scratch)
 221     (define-key map "\C-c\C-e" 'sepia-eval-expression)
 222     (define-key map "\C-c!" 'sepia-set-cwd)
 223     (define-key map (kbd "TAB") 'sepia-indent-or-complete)
 224     map)
 225   "Sepia bindings common to all modes.")
 226
 227 ;;;###autoload
 228 (defun sepia-perldoc-this (name)
 229   "View perldoc for module at point."
 230   (interactive (list (sepia-interactive-arg 'module)))
 231   (let ((wc (current-window-configuration))
 232         (old-pd (symbol-function 'w3m-about-perldoc))
 233         (old-pdb (symbol-function 'w3m-about-perldoc-buffer)))
 234     (condition-case stuff
 235         (flet ((w3m-about-perldoc (&rest args)
 236                  (let ((res (apply old-pd args)))
 237                    (or res (error "lose: %s" args))))
 238                (w3m-about-perldoc-buffer (&rest args)
 239                  (let ((res (apply old-pdb args)))
 240                    (or res (error "lose: %s" args)))))
 241           (funcall (if (featurep 'w3m) 'w3m-perldoc 'cperl-perldoc) name))
 242       (error (set-window-configuration wc)))))
 243
 244 (defun sepia-view-pod ()
 245   "View POD for the current buffer."
 246   (interactive)
 247   (funcall sepia-view-pod-function))
 248
 249 (defun sepia-module-list ()
 250   "List installed modules with links to their documentation.
 251
 252 This lists not just top-level packages appearing in packlist
 253 files, but all documented modules on the system, organized by
 254 package."
 255   (interactive)
 256   (let ((file "/tmp/modlist.html"))
 257     ;; (unless (file-exists-p file)
 258     (sepia-eval-raw (format "Sepia::html_module_list(\"%s\")" file))
 259     (funcall sepia-module-list-function file)))
 260
 261 (defun sepia-package-list ()
 262   "List installed packages with links to their documentation.
 263
 264 This lists only top-level packages appearing in packlist files.
 265 For modules within packages, see `sepia-module-list'."
 266   (interactive)
 267   (let ((file "/tmp/packlist.html"))
 268     ;; (unless (file-exists-p file)
 269     (sepia-eval-raw (format "Sepia::html_package_list(\"%s\")" file))
 270     (funcall sepia-module-list-function file)))
 271
 272 (defun sepia-perldoc-buffer ()
 273   "View current buffer's POD using pod2html and `browse-url'.
 274
 275 Interactive users should call `sepia-view-pod'."
 276   (let ((buffer (get-buffer-create "*sepia-pod*"))
 277         (errs (get-buffer-create "*sepia-pod-errors*"))
 278         (inhibit-read-only t))
 279     (with-current-buffer buffer (erase-buffer))
 280     (save-window-excursion
 281       (shell-command-on-region (point-min) (point-max) "pod2html"
 282                                buffer nil errs))
 283     (with-current-buffer buffer (browse-url-of-buffer))))
 284
 285 (defun sepia-perl-name (sym &optional mod)
 286 "Convert a Perl name to a Lisp name."
 287   (setq sym (substitute ?_ ?- (if (symbolp sym) (symbol-name sym) sym)))
 288   (if mod
 289       (concat mod "::" sym)
 290       sym))
 291
 292 (defun sepia-live-p ()
 293   (and (processp sepia-process)
 294        (eq (process-status sepia-process) 'run)))
 295
 296 (defun sepia-ensure-process (&optional remote-host)
 297   (unless (sepia-live-p)
 298     (with-current-buffer (get-buffer-create "*sepia-repl*")
 299       (sepia-repl-mode)
 300       (set (make-local-variable 'sepia-passive-output) ""))
 301     (if remote-host
 302         (comint-exec "*sepia-repl*" "attachtty" "attachtty" nil
 303                      (list remote-host))
 304         (let ((stuff (split-string sepia-program-name nil t)))
 305           (comint-exec (get-buffer-create "*sepia-repl*")
 306                        "perl" (car stuff) nil
 307                        (append
 308                         (cdr stuff)
 309                         (mapcar (lambda (x) (concat "-I" x)) sepia-perl5lib)
 310                         '("-MSepia" "-MSepia::Xref"
 311                           "-e" "Sepia::repl")))))
 312     (setq sepia-process (get-buffer-process "*sepia-repl*"))
 313     (accept-process-output sepia-process 1)
 314     ;; Steal a bit from gud-common-init:
 315     (setq gud-running t)
 316     (setq gud-last-last-frame nil)
 317     (set-process-filter sepia-process 'gud-filter)
 318     (set-process-sentinel sepia-process 'gud-sentinel)))
 319
 320 ;;;###autoload
 321 (defun sepia-repl (&optional remote-host)
 322   "Start the Sepia REPL."
 323   (interactive (list (and current-prefix-arg
 324                           (read-string "Host: "))))
 325   (sepia-init) ;; set up keymaps, etc.
 326   (sepia-ensure-process remote-host)
 327   (pop-to-buffer (get-buffer "*sepia-repl*")))
 328
 329 (defvar sepia-repl-mode-map
 330   (let ((map (copy-keymap sepia-shared-map)))
 331     (set-keymap-parent map gud-mode-map)
 332     (define-key map (kbd "<tab>") 'comint-dynamic-complete)
 333     (define-key map "\C-a" 'comint-bol)
 334     map)
 335
 336 "Keymap for Sepia interactive mode.")
 337
 338 (define-derived-mode sepia-repl-mode gud-mode "Sepia REPL"
 339   "Major mode for the Sepia REPL.
 340
 341 \\{sepia-repl-mode-map}"
 342     (set (make-local-variable 'comint-dynamic-complete-functions)
 343          '(sepia-complete-symbol comint-dynamic-complete-filename))
 344     (set (make-local-variable 'comint-preoutput-filter-functions)
 345          '(sepia-watch-for-eval))
 346     ;; (set (make-local-variable 'comint-use-prompt-regexp) t)
 347     (modify-syntax-entry ?: "_")
 348     (modify-syntax-entry ?> ".")
 349     (set (make-local-variable 'comint-prompt-regexp) "^[^>\n]*> *")
 350     (set (make-local-variable 'gud-target-name) "sepia")
 351     (set (make-local-variable 'gud-marker-filter) 'sepia-gud-marker-filter)
 352     (set (make-local-variable 'gud-minor-mode) 'sepia)
 353
 354     (setq gud-comint-buffer (current-buffer))
 355     (setq gud-last-last-frame nil)
 356     (setq gud-sepia-acc nil)
 357
 358     (gud-def gud-break ",break %f:%l" "\C-b" "Set breakpoint at current line.")
 359     (gud-def gud-step ",step %p" "\C-s" "Step one line.")
 360     (gud-def gud-next ",next %p" "\C-n" "Step one line, skipping calls.")
 361     (gud-def gud-cont ",continue" "\C-r" "Continue.")
 362     (gud-def gud-print "%e" "\C-p" "Evaluate something.")
 363     (gud-def gud-remove ",delete %l %f" "\C-d" "Delete current breakpoint.")
 364     ;; Sadly, this hoses our keybindings.
 365     (compilation-shell-minor-mode 1)
 366     (run-hooks 'sepia-repl-mode-hook))
 367
 368 (defvar gud-sepia-acc nil
 369   "Accumulator for `sepia-gud-marker-filter'.")
 370
 371 (defun sepia-gud-marker-filter (str)
 372   (setq gud-sepia-acc
 373         (if gud-sepia-acc
 374             (concat gud-sepia-acc str)
 375             str))
 376   (while (string-match "_<\\([^:>]+\\):\\([0-9]+\\)>\\(.*\\)" gud-sepia-acc)
 377     (setq gud-last-last-frame gud-last-frame
 378           gud-last-frame (cons
 379                           (match-string 1 gud-sepia-acc)
 380                           (string-to-number (match-string 2 gud-sepia-acc)))
 381           gud-sepia-acc (match-string 3 gud-sepia-acc)))
 382   (setq gud-sepia-acc
 383         (if (string-match "\\(_<.*\\)" gud-sepia-acc)
 384             (match-string 1 gud-sepia-acc)
 385             nil))
 386   str)
 387
 388 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 389 ;;; Xref
 390
 391 (defun define-xref-function (package name doc)
 392   "Define a lisp mirror for a low-level Sepia function."
 393   (let ((lisp-name (intern (format "xref-%s" name)))
 394         (pl-name (sepia-perl-name name package)))
 395     (fmakunbound lisp-name)
 396     (eval `(defun ,lisp-name (&rest args)
 397              ,doc
 398              (apply #'sepia-call ,pl-name 'list-context args)))))
 399
 400 (defun define-modinfo-function (name &optional doc context)
 401 "Define a lisp mirror for a function from Module::Info."
 402   (let ((name (intern (format "sepia-module-%s" name)))
 403         (pl-func (sepia-perl-name name))
 404         (full-doc (concat (or doc "") "
 405
 406 This function uses Module::Info, so it does not require that the
 407 module in question be loaded.")))
 408     (when (fboundp name) (fmakunbound name))
 409     (eval `(defun ,name (mod)
 410              ,full-doc
 411              (interactive (list (sepia-interactive-arg 'module)))
 412              (sepia-maybe-echo
 413               (sepia-call "Sepia::module_info" ',(or context 'scalar-context)
 414                          mod ,pl-func)
 415               (interactive-p))))))
 416
 417 (defun sepia-thing-at-point (what)
 418   "Like `thing-at-point', but hacked to avoid REPL prompt."
 419   (let ((th (thing-at-point what)))
 420     (and th (not (string-match "[ >]$" th)) th)))
 421
 422 (defvar sepia-sub-re "^ *sub\\s +\\(.+\\_>\\)")
 423
 424 (defvar sepia-history nil)
 425
 426 (defun sepia-interactive-arg (&optional sepia-arg-type)
 427 "Default argument for most Sepia functions.  TYPE is a symbol --
 428 either 'file to look for a file, or anything else to use the
 429 symbol at point."
 430   (let* ((default (case sepia-arg-type
 431                     (file (or (thing-at-point 'file) (buffer-file-name)))
 432                     (t (sepia-thing-at-point 'symbol))))
 433          (text (capitalize (symbol-name sepia-arg-type)))
 434          (choices
 435           (lambda (str &rest blah)
 436             (let ((completions (xref-completions
 437                                 str
 438                                 (case sepia-arg-type
 439                                   (module nil)
 440                                   (variable "VARIABLE")
 441                                   (function "CODE")
 442                                   (t nil)))))
 443               (when (eq sepia-arg-type 'module)
 444                 (setq completions
 445                       (remove-if (lambda (x) (string-match "::$" x)) completions)))
 446               completions)))
 447          (prompt (if default
 448                      (format "%s [%s]: " text default)
 449                      (format "%s: " text)))
 450          (ret (if sepia-use-completion
 451                   (completing-read prompt 'blah-choices nil nil nil 'sepia-history
 452                                    default)
 453                   (read-string prompt nil 'sepia-history default))))
 454     (push ret sepia-history)
 455     ret))
 456
 457 (defun sepia-interactive-module ()
 458 "Guess which module we should look things up in.  Prompting for a
 459 module all the time is a PITA, but I don't think this (choosing
 460 the current file's module) is a good alternative, either.  Best
 461 would be to choose the module based on what we know about the
 462 symbol at point."
 463   (let ((xs (xref-file-modules (buffer-file-name))))
 464     (if (= (length xs) 1)
 465         (car xs)
 466         nil)))
 467
 468 (defun sepia-maybe-echo (result &optional print-message)
 469   (when print-message
 470     (message "%s" result))
 471   result)
 472
 473 (defun sepia-find-module-file (mod)
 474   (or (sepia-module-file mod)
 475       (car (xref-guess-module-file mod))))
 476
 477 (defun sepia-module-find (mod)
 478 "Find the file defining module MOD."
 479   (interactive (list (sepia-interactive-arg 'module)))
 480   (let ((fn (sepia-find-module-file mod)))
 481     (if fn
 482         (progn
 483           (message "Module %s in %s." mod fn)
 484           (pop-to-buffer (find-file-noselect (expand-file-name fn))))
 485         (message "Can't find module %s." mod))))
 486
 487 (defmacro ifa (test then &rest else)
 488   `(let ((it ,test))
 489      (if it ,then ,@else)))
 490
 491 (defvar sepia-found-refiner)
 492
 493 (defun sepia-show-locations (locs)
 494   (when locs
 495     (pop-to-buffer (get-buffer-create "*sepia-places*"))
 496     (let ((inhibit-read-only t))
 497       (erase-buffer)
 498       (dolist (loc (sort (remove nil locs) ; XXX where's nil from?
 499                          (lambda (a b)
 500                            (or (string< (car a) (car b))
 501                                (and (string= (car a) (car b))
 502                                     (< (second a) (second b)))))))
 503         (destructuring-bind (file line name &rest blah) loc
 504           (let ((str (ifa (find-buffer-visiting file)
 505                           (with-current-buffer it
 506                             (ifa sepia-found-refiner
 507                                  (funcall it line name)
 508                                  (goto-line line))
 509                             (message "line for %s was %d, now %d" name line
 510                                      (line-number-at-pos))
 511                             (setq line (line-number-at-pos))
 512                             (let ((tmpstr
 513                                    (buffer-substring (sepia-bol-from (point))
 514                                                      (sepia-eol-from (point)))))
 515                               (if (> (length tmpstr) 60)
 516                                   (concat "\n    " tmpstr)
 517                                   tmpstr)))
 518                           "...")))
 519             (insert (format "%s:%d:%s\n" (abbreviate-file-name file) line str)))))
 520       (grep-mode)
 521       (goto-char (point-min)))))
 522
 523 (defmacro define-sepia-query (name doc &optional gen test prompt)
 524   "Define a sepia querying function."
 525   `(defun ,name (ident &optional module file line display-p)
 526      ,(concat doc "
 527
 528 With prefix arg, list occurences in a `grep-mode' buffer.
 529 Without, place the occurrences on `sepia-found', so that
 530 calling `sepia-next' will cycle through them.
 531
 532 Depending on the query, MODULE, FILE, and LINE may be used to
 533 narrow the results, as long as doing so leaves some matches.
 534 When called interactively, they are taken from the current
 535 buffer.
 536 ")
 537      (interactive (list (sepia-interactive-arg ,(or prompt ''function))
 538                         (sepia-interactive-module)
 539                         (buffer-file-name)
 540                         (line-number-at-pos (point))
 541                         current-prefix-arg
 542                         ))
 543      (let ((ret
 544             ,(if test
 545                  `(let ((tmp (,gen ident module file line)))
 546                     (or (mapcan #',test tmp) tmp))
 547                  `(,gen ident module file line))))
 548        ;; Always clear out the last found ring, because it's confusing
 549        ;; otherwise.
 550        (sepia-set-found nil ,(or prompt ''function))
 551        (if display-p
 552            (sepia-show-locations ret)
 553            (sepia-set-found ret ,(or prompt ''function))
 554            (sepia-next)))))
 555
 556 (define-sepia-query sepia-defs
 557     "Find all definitions of sub."
 558   xref-apropos
 559   xref-location)
 560
 561 (define-sepia-query sepia-callers
 562     "Find callers of FUNC."
 563   xref-callers
 564   xref-location)
 565
 566 (define-sepia-query sepia-callees
 567     "Find a sub's callees."
 568   xref-callees
 569   xref-location)
 570
 571 (define-sepia-query sepia-var-defs
 572     "Find a var's definitions."
 573   xref-var-defs
 574   (lambda (x) (setf (third x) ident) (list x))
 575   'variable)
 576
 577 (define-sepia-query sepia-var-uses
 578     "Find a var's uses."
 579   xref-var-uses
 580   (lambda (x) (setf (third x) ident) (list x))
 581   'variable)
 582
 583 (define-sepia-query sepia-var-assigns
 584     "Find/list assignments to a variable."
 585   xref-var-assigns
 586   (lambda (x) (setf (third x) ident) (list x))
 587   'variable)
 588
 589 (defalias 'sepia-package-defs 'sepia-module-describe)
 590
 591 (define-sepia-query sepia-apropos
 592     "Find/list subroutines matching regexp."
 593   (lambda (name &rest blah) (xref-apropos name 1))
 594   xref-location
 595   'function)
 596
 597 (define-sepia-query sepia-var-apropos
 598     "Find/list variables matching regexp."
 599   xref-var-apropos
 600   xref-var-defs
 601   'variable)
 602
 603 (defun sepia-location (name &optional jump-to)
 604   "Find the definition of NAME.
 605
 606 When called interactively (or with JUMP-TO true), go directly
 607 to this location."
 608   (interactive (list (sepia-interactive-arg 'function) t))
 609   (let* ((fl (or (car (xref-location name))
 610                  (car (remove-if #'null
 611                                  (apply #'xref-location (xref-apropos name)))))))
 612     (when (and (car fl) (string-match "^(eval " (car fl)))
 613       (message "Can't find definition of %s in %s." name (car fl))
 614       (setq fl nil))
 615     (if jump-to
 616         (if fl (progn
 617                  (sepia-set-found (list fl) 'function)
 618                  (sepia-next))
 619             (message "No definition for %s." name))
 620         fl)))
 621
 622 ;;;###autoload
 623 (defun sepia-dwim (&optional display-p)
 624     "Try to do the right thing with identifier at point.
 625 * Find all definitions, if thing-at-point is a function
 626 * Find all uses, if thing-at-point is a variable
 627 * Find documentation, if thing-at-point is a module
 628 * Prompt otherwise
 629 "
 630     (interactive "P")
 631     (multiple-value-bind (type obj) (sepia-ident-at-point)
 632       (sepia-set-found nil type)
 633       (let* ((module-doc-p nil)
 634              (ret
 635               (cond
 636                 ((member type '(?% ?$ ?@)) (xref-var-defs obj))
 637                 ((or (equal type ?&)
 638                      (let (case-fold-search)
 639                        (string-match "^[^A-Z]" obj)))
 640                  (list (sepia-location obj)))
 641                 ((sepia-looks-like-module obj)
 642                  (setq module-doc-p t)
 643                  `((,(sepia-perldoc-this obj) 1 nil nil)))
 644                 (t (setq module-doc-p t)
 645                    (call-interactively 'sepia-defs)))))
 646         (unless module-doc-p
 647           (if display-p
 648               (sepia-show-locations ret)
 649               (sepia-set-found ret type)
 650               (sepia-next))))))
 651
 652 (defun sepia-rebuild ()
 653   "Rebuild the Xref database."
 654   (interactive)
 655   (xref-rebuild))
 656
 657 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 658 ;;; Perl motion commands.
 659
 660 ;;; XXX -- these are a hack to prevent infinite recursion calling
 661 ;;; e.g. beginning-of-defun from beginning-of-defun-function.
 662 ;;; `beginning-of-defun' should handle this.
 663 (defmacro sepia-safe-bodf (&optional n)
 664   `(let ((beginning-of-defun-function
 665           (if (and (boundp 'beginning-of-defun-function)
 666                    (eq beginning-of-defun-function 'sepia-beginning-of-defun))
 667               nil
 668               beginning-of-defun-function)))
 669      (beginning-of-defun ,n)))
 670
 671 (defmacro sepia-safe-eodf (&optional n)
 672   `(let ((end-of-defun-function
 673           (if (and (boundp 'end-of-defun-function)
 674                    (eq end-of-defun-function 'sepia-end-of-defun))
 675               nil
 676               end-of-defun-function)))
 677      (end-of-defun ,n)))
 678
 679 (defun sepia-beginning-of-defun (&optional n)
 680 "Move to beginning of current function.
 681
 682 The prefix argument is the same as for `beginning-of-defun'."
 683   (interactive "p")
 684   (setq n (or n 1))
 685   (ignore-errors
 686     (when (< n 0)
 687       (sepia-end-of-defun (- n))
 688       (setq n 1))
 689     (re-search-backward sepia-sub-re nil nil n)))
 690
 691 (defun sepia-inside-defun ()
 692   "True if point is inside a sub."
 693   (condition-case nil
 694       (save-excursion
 695         (let ((cur (point)))
 696           (re-search-backward sepia-sub-re)
 697           (when (< (point) cur)
 698             (search-forward "{")
 699             (backward-char 1)
 700             (forward-sexp)
 701             (> (point) cur))))
 702     (error nil)))
 703
 704 (defun sepia-end-of-defun (&optional n)
 705   "Move to end of current function.
 706
 707 The prefix argument is the same as for `end-of-defun'."
 708   (interactive "p")
 709   (setq n (or n 1))
 710   (when (< n 0)
 711     (sepia-beginning-of-defun (- n))
 712     (setq n 1))
 713   ;; If we're outside a defun, skip to the next
 714   (ignore-errors
 715     (unless (sepia-inside-defun)
 716       (re-search-forward sepia-sub-re)
 717       (forward-char 1))
 718     (dotimes (i n)
 719       (re-search-backward sepia-sub-re)
 720       (search-forward "{")
 721       (backward-char 1)
 722       (forward-sexp))
 723     (point)))
 724
 725 (defun sepia-defun-around-point (&optional where)
 726   "Return the text of function around point."
 727   (unless where
 728     (setq where (point)))
 729   (save-excursion
 730     (goto-char where)
 731     (and (sepia-beginning-of-defun)
 732          (match-string-no-properties 1))))
 733
 734 (defun sepia-lexicals-at-point (&optional where)
 735   "Find lexicals in scope at point."
 736   (interactive "d")
 737   (unless where
 738     (setq where (point)))
 739   (let ((subname (sepia-defun-around-point where))
 740         (mod (sepia-buffer-package)))
 741     (xref-lexicals (sepia-perl-name subname mod))))
 742
 743 ;;;###autoload
 744 (defun sepia-load-file (file &optional rebuild-p collect-warnings)
 745   "Reload a file (interactively, the current buffer's file).
 746
 747 With REBUILD-P (or a prefix argument when called interactively),
 748 also rebuild the xref database."
 749   (interactive (list (expand-file-name (buffer-file-name))
 750                      prefix-arg
 751                      (format "*%s errors*" (buffer-file-name))))
 752   (save-buffer)
 753   (when collect-warnings
 754     (let (kill-buffer-query-functions)
 755       (ignore-errors
 756         (kill-buffer collect-warnings))))
 757   (let* ((tmp (sepia-eval (format "do '%s' || ($@ && do { local $Sepia::Debug::STOPDIE; die $@ })" file)
 758                           'scalar-context t))
 759          (res (car tmp))
 760          (errs (cdr tmp)))
 761     (message "sepia: %s returned %s" (abbreviate-file-name file)
 762              (if (equal res "") "undef" res))
 763     (when (and collect-warnings
 764                (> (length errs) 1))
 765       (with-current-buffer (get-buffer-create collect-warnings)
 766         (let ((inhibit-read-only t))
 767           (delete-region (point-min) (point-max))
 768           (insert errs)
 769           (sepia-display-errors (point-min) (point-max))
 770           (pop-to-buffer (current-buffer))))))
 771   (when rebuild-p
 772     (xref-rebuild)))
 773
 774 (defvar sepia-found)
 775
 776 (defun sepia-set-found (list &optional type)
 777   (setq list
 778         (remove-if (lambda (x)
 779                      (or (not x)
 780                          (and (not (car x)) (string= (fourth x) "main"))))
 781                    list))
 782   (setq sepia-found (cons -1 list))
 783   (setq sepia-found-refiner (sepia-refiner type)))
 784
 785 (defun sepia-refiner (type)
 786   (case type
 787     (function
 788      (lambda (line ident)
 789       (let ((sub-re (concat "^\\s *sub\\s +.*" ident "\\_>")))
 790         ;; Test this because sometimes we get lucky and get the line
 791         ;; just right, in which case beginning-of-defun goes to the
 792         ;; previous defun.
 793           (or (and line
 794                    (progn
 795                      (goto-line line)
 796                      (beginning-of-defun)
 797                      (looking-at sub-re)))
 798               (progn (goto-char (point-min))
 799                      (re-search-forward sub-re nil t)))
 800           (beginning-of-line))))
 801     ;; Old version -- this may actually work better if
 802     ;; beginning-of-defun goes flaky on us.
 803 ;;         (or (re-search-backward sub-re
 804 ;;                                 (sepia-bol-from (point) -20) t)
 805 ;;             (re-search-forward sub-re
 806 ;;                                (sepia-bol-from (point) 10) t))
 807 ;;         (beginning-of-line)
 808     (variable
 809      (lambda (line ident)
 810        (let ((var-re (concat "\\_<" ident "\\_>")))
 811          (cond
 812            (line (goto-line line)
 813                  (or (re-search-backward var-re (sepia-bol-from (point) -5) t)
 814                      (re-search-forward var-re (sepia-bol-from (point) 5) t)))
 815            (t (goto-char (point-min))
 816               (re-search-forward var-re nil t))))))
 817     (t (lambda (line ident) (and line (goto-line line))))))
 818
 819 (defun sepia-next (&optional arg)
 820   "Go to the next thing (e.g. def, use) found by sepia."
 821   (interactive "p")
 822   (or arg (setq arg 1))
 823   (if (cdr sepia-found)
 824       (let ((i (car sepia-found))
 825             (list (cdr sepia-found))
 826             (len (length (cdr sepia-found)))
 827             (next (+ (car sepia-found) arg))
 828             (prompt ""))
 829         (if (and (= len 1) (>= i 0))
 830             (message "No more definitions.")
 831           ;; if stepwise found next or previous item, it can cycle
 832           ;; around the `sepia-found'. When at first or last item, get
 833           ;; a warning
 834           (if (= (abs arg) 1)
 835               (progn
 836                 (setq i next)
 837                 (if (< i 0)
 838                     (setq i (1- len))
 839                   (if (>= i len)
 840                       (setq i 0)))
 841                 (if (= i (1- len))
 842                     (setq prompt "Last one! ")
 843                   (if (= i 0)
 844                       (setq prompt "First one! "))))
 845             ;; if we skip several item, when arrive the first or last
 846             ;; item, we will stop at the one. But if we already at last
 847             ;; item, then keep going
 848             (if (< next 0)
 849                 (if (= i 0)
 850                     (setq i (mod next len))
 851                   (setq i 0
 852                         prompt "First one!"))
 853               (if (> next len)
 854                   (if (= i (1- len))
 855                       (setq i (mod next len))
 856                     (setq i (1- len)
 857                           prompt "Last one!")))))
 858           (setcar sepia-found i)
 859           (setq next (nth i list))
 860           (let ((file (car next))
 861                 (line (cadr next))
 862                 (short (nth 2 next))
 863                 (mod (nth 3 next)))
 864         (unless file
 865           (setq file (and mod (sepia-find-module-file mod)))
 866           (if file
 867                   (setcar next file)
 868                 (error "No file for %s." (car next))))
 869             (message "%s at %s:%s. %s" short file line prompt)
 870         (when (file-exists-p file)
 871           (find-file (or file (sepia-find-module-file mod)))
 872           (when sepia-found-refiner
 873             (funcall sepia-found-refiner line short))
 874           (beginning-of-line)
 875               (recenter)))))
 876       (message "No more definitions.")))
 877
 878 (defun sepia-previous (&optional arg)
 879   (interactive "p")
 880   (or arg (setq arg 1))
 881   (sepia-next (- arg)))
 882
 883 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 884 ;; Completion
 885
 886 (defun sepia-ident-before-point ()
 887   "Find the Perl identifier at or preceding point."
 888   (save-excursion
 889     (let* ((end (point))
 890            (beg (progn
 891                   (skip-chars-backward "a-zA-Z0-9_:")
 892                   (point)))
 893            (sigil (if (= beg (point-min))
 894                       nil
 895                       (char-before (point)))))
 896       (list (when (member sigil '(?$ ?@ ?% ?* ?&)) sigil)
 897             (buffer-substring-no-properties beg end)))))
 898
 899 (defun sepia-simple-method-before-point ()
 900   "Find the \"simple\" method call before point.
 901
 902 Looks for a simple method called on a variable before point and
 903 returns the list (OBJECT METHOD).  For example, \"$x->blah\"
 904 returns '(\"$x\" \"blah\").  Only simple methods are recognized,
 905 because completing anything evaluates it, so completing complex
 906 expressions would lead to disaster."
 907   (when sepia-complete-methods
 908     (let ((end (point))
 909           (bound (max (- (point) 100) (point-min)))
 910           arrow beg)
 911       (save-excursion
 912         ;; XXX - can't do this because COMINT's syntax table is weird.
 913         ;; (skip-syntax-backward "_w")
 914         (skip-chars-backward "a-zA-Z0-9_")
 915         (when (looking-back "->\\s *" bound)
 916           (setq arrow (search-backward "->" bound))
 917           (skip-chars-backward "a-zA-Z0-9_:")
 918           (cond
 919             ;; $x->method
 920             ((char-equal (char-before (point)) ?$)
 921              (setq beg (1- (point))))
 922             ;; X::Class->method
 923             ((multiple-value-bind (type obj) (sepia-ident-at-point)
 924                (and (not type)
 925                     (sepia-looks-like-module obj)))
 926              (setq beg (point))))
 927           (when beg
 928             (list (buffer-substring-no-properties beg arrow)
 929                   (buffer-substring-no-properties (+ 2 arrow) end)
 930                   (buffer-substring-no-properties beg end))))))))
 931
 932 (defun sepia-ident-at-point ()
 933   "Find the Perl identifier at point."
 934   (save-excursion
 935     (when (looking-at "[%$@*&]")
 936       (forward-char 1))
 937     (let* ((beg (progn
 938                  (when (re-search-backward "[^A-Za-z_0-9:]" nil 'mu)
 939                    (forward-char 1))
 940                  (point)))
 941           (sigil (if (= beg (point-min))
 942                      nil
 943                      (char-before (point))))
 944           (end (progn
 945                  (when (re-search-forward "[^A-Za-z_0-9:]" nil 'mu)
 946                    (forward-char -1))
 947                  (point))))
 948       (list (when (member sigil '(?$ ?@ ?% ?* ?&)) sigil)
 949             (buffer-substring-no-properties beg end)))))
 950
 951 (defun sepia-function-at-point ()
 952   "Find the Perl function called at point."
 953   (condition-case nil
 954       (save-excursion
 955         (let ((pt (point))
 956               bof)
 957           (sepia-beginning-of-defun)
 958           (setq bof (point))
 959           (goto-char pt)
 960           (sepia-end-of-defun)
 961           (when (and (>= pt bof) (< pt (point)))
 962             (goto-char bof)
 963             (looking-at "\\s *sub\\s +")
 964             (forward-char (length (match-string 0)))
 965             (concat (or (sepia-buffer-package) "")
 966                     "::"
 967                     (cadr (sepia-ident-at-point))))))
 968     (error nil)))
 969
 970 (defun sepia-repl-complete ()
 971   "Try to complete the word at point in the REPL.
 972 Just like `sepia-complete-symbol', except that it also completes
 973 REPL shortcuts."
 974   (interactive)
 975   (error "TODO"))
 976
 977 (defvar sepia-shortcuts
 978   '("break" "cd" "debug" "define" "delete" "eval" "format" "help" "lsbreak"
 979     "methods" "package" "pwd" "quit" "reload" "shell" "size" "strict" "undef"
 980     "wantarray")
 981   "List of currently-defined REPL shortcuts.
 982
 983 XXX: this needs to be updated whenever you add one on the Perl side.")
 984
 985 (defun sepia-complete-symbol ()
 986   "Try to complete the word at point.
 987 The word may be either a global variable if it has a
 988 sigil (sorry, no lexicals), a module, or a function.  The
 989 function currently ignores module qualifiers, which may be
 990 annoying in larger programs.
 991
 992 The function is intended to be bound to \\M-TAB, like
 993 `lisp-complete-symbol'."
 994   (interactive)
 995   (let ((win (get-buffer-window "*Completions*" 0))
 996         len
 997         completions
 998         type
 999         meth)
1000     (if (and (eq last-command this-command)
1001              win (window-live-p win) (window-buffer win)
1002              (buffer-name (window-buffer win)))
1003
1004         ;; If this command was repeated, and
1005         ;; there's a fresh completion window with a live buffer,
1006         ;; and this command is repeated, scroll that window.
1007         (with-current-buffer (window-buffer win)
1008           (if (pos-visible-in-window-p (point-max) win)
1009               (set-window-start win (point-min))
1010             (save-selected-window
1011               (select-window win)
1012               (scroll-up))))
1013
1014       ;; Otherwise actually do completion:
1015       ;; 0 - try a shortcut
1016       (when (eq major-mode 'sepia-repl-mode)
1017         (save-excursion
1018           (comint-bol)
1019           (when (looking-at ",\\([a-z]+\\)$")
1020             (let ((str (match-string 1)))
1021               (setq len (length str)
1022                     completions (all-completions str sepia-shortcuts))))))
1023       ;; 1 - Look for a method call:
1024       (unless completions
1025         (setq meth (sepia-simple-method-before-point))
1026         (when meth
1027           (setq len (length (caddr meth))
1028                 completions (xref-method-completions
1029                              (cons 'expr (format "'%s'" (car meth)))
1030                              (cadr meth)
1031                              "Sepia::repl_eval")
1032                 type (format "%s->" (car meth)))))
1033       (multiple-value-bind (typ name) (sepia-ident-before-point)
1034         (unless completions
1035           ;; 2 - look for a regular function/variable/whatever
1036           (setq type typ
1037                 len (+ (if type 1 0) (length name))
1038                 completions (xref-completions
1039                              name
1040                              (case type
1041                                (?$ "VARIABLE")
1042                                (?@ "ARRAY")
1043                                (?% "HASH")
1044                                (?& "CODE")
1045                                (?* "IO")
1046                                (t ""))
1047                              (and (eq major-mode 'sepia-mode)
1048                                   (sepia-function-at-point)))))
1049         ;; 3 - try a Perl built-in
1050         (when (and (not completions)
1051                    (or (not type) (eq type ?&)))
1052           (when (string-match ".*::([^:]+)$" name)
1053             (setq name (match-string 1 name)))
1054           (setq completions (all-completions name sepia-perl-builtins)))
1055         (case (length completions)
1056           (0 (message "No completions.") nil)
1057           (1 ;; XXX - skip sigil to match s-i-before-point
1058            (delete-region (- (point) len) (point))
1059            (insert (or type "") (car completions))
1060            ;; Hide stale completions buffer (stolen from lisp.el).
1061            (if win (with-selected-window win (bury-buffer))) t)
1062           (t (let ((old name)
1063                    (new (try-completion "" completions)))
1064                (if (<= (length new) (length old))
1065                    (with-output-to-temp-buffer "*Completions*"
1066                      (display-completion-list completions))
1067                  (let ((win (get-buffer-window "*Completions*" 0)))
1068                    (if win (with-selected-window win (bury-buffer))))
1069                  (delete-region (- (point) len) (point))
1070                  (insert (or type "") new))))))
1071       t)))
1072
1073 (defun sepia-indent-or-complete ()
1074 "Indent the current line or complete the symbol around point.
1075
1076 Specifically, try completion when indentation doesn't move point.
1077 This function is intended to be bound to TAB."
1078   (interactive)
1079   (let ((pos (point)))
1080     (let (beginning-of-defun-function
1081           end-of-defun-function)
1082       (cperl-indent-command))
1083     (when (and (= pos (point))
1084                (not (bolp))
1085                (or (eq last-command 'sepia-indent-or-complete)
1086                    (looking-at "\\_>")))
1087       (unless (and sepia-indent-expand-abbrev
1088                    (expand-abbrev))
1089         (sepia-complete-symbol)))))
1090
1091 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1092 ;;; scratchpad code
1093
1094 (defvar sepia-mode-map
1095   (let ((map (copy-keymap sepia-shared-map)))
1096     (set-keymap-parent map cperl-mode-map)
1097     (define-key map "\C-c\C-h" nil)
1098     map)
1099  "Keymap for Sepia mode.")
1100
1101 (defvar sepia-mode-abbrev-table nil
1102 "Abbrevs for Sepia mode.")
1103
1104 ;;;###autoload
1105 (define-derived-mode sepia-mode cperl-mode "Sepia"
1106   "Major mode for Perl editing, derived from cperl mode.
1107 \\{sepia-mode-map}"
1108   :abbrev-table nil
1109   (sepia-init)
1110   (sepia-install-eldoc)
1111   (sepia-doc-update)
1112   (set (make-local-variable 'beginning-of-defun-function)
1113        'sepia-beginning-of-defun)
1114   (set (make-local-variable 'end-of-defun-function)
1115        'sepia-end-of-defun))
1116
1117 (defun sepia-init ()
1118   "Perform the initialization necessary to start Sepia."
1119     ;; Load perl defs:
1120   ;; Create glue wrappers for Module::Info funcs.
1121   (unless (fboundp 'xref-completions)
1122     (dolist (x '((name "Find module name.\n\nDoes not require loading.")
1123                  (version "Find module version.\n\nDoes not require loading.")
1124                  (inc-dir "Find directory in which this module was found.\n\nDoes not require loading.")
1125                  (file "Absolute path of file defining this module.\n\nDoes not require loading.")
1126                  (is-core "Guess whether or not a module is part of the core distribution.
1127 Does not require loading.")
1128                  (modules-used "List modules used by this module.\n\nRequires loading." list-context)
1129                  (packages-inside "List sub-packages in this module.\n\nRequires loading." list-context)
1130                  (superclasses "List module's superclasses.\n\nRequires loading." list-context)))
1131       (apply #'define-modinfo-function x))
1132     ;; Create low-level wrappers for Sepia
1133     (dolist (x '((completions "Find completions in the symbol table.")
1134                  (method-completions "Complete on an object's methods.")
1135                  (location "Find an identifier's location.")
1136                  (mod-subs "Find all subs defined in a package.")
1137                  (mod-decls "Generate declarations for subs in a package.")
1138                  (mod-file "Find the file defining a package.")
1139                  (apropos "Find subnames matching RE.")
1140                  (lexicals "Find lexicals for a sub.")
1141                  ))
1142       (apply #'define-xref-function "Sepia" x))
1143
1144     (dolist (x '((rebuild "Build Xref database for current Perl process.")
1145                  (redefined "Rebuild Xref information for a given sub.")
1146
1147                  (callers "Find all callers of a function.")
1148                  (callees "Find all functions called by a function.")
1149
1150                  (var-apropos "Find varnames matching RE.")
1151                  (mod-apropos "Find modules matching RE.")
1152                  (file-apropos "Find files matching RE.")
1153
1154                  (var-defs "Find all definitions of a variable.")
1155                  (var-assigns "Find all assignments to a variable.")
1156                  (var-uses "Find all uses of a variable.")
1157
1158                  (mod-redefined "Rebuild Xref information for a given package.")
1159                  (guess-module-file "Guess file corresponding to module.")
1160                  (file-modules "List the modules defined in a file.")))
1161       (apply #'define-xref-function "Sepia::Xref" x))
1162     ;; Initialize built hash
1163     (sepia-init-perl-builtins)))
1164
1165 (defvar sepia-scratchpad-mode-map
1166   (let ((map (make-sparse-keymap)))
1167     (set-keymap-parent map sepia-mode-map)
1168     (define-key map "\C-j" 'sepia-scratch-send-line)
1169     map))
1170
1171 ;;;###autoload
1172 (define-derived-mode sepia-scratchpad-mode sepia-mode "Sepia-Scratch"
1173   "Major mode for the Perl scratchpad, derived from Sepia mode."
1174   (sepia-init))
1175
1176 ;;;###autoload
1177 (defun sepia-scratch ()
1178   "Switch to the sepia scratchpad."
1179   (interactive)
1180   (pop-to-buffer
1181    (or (get-buffer "*sepia-scratch*")
1182        (with-current-buffer (get-buffer-create "*sepia-scratch*")
1183          (sepia-scratchpad-mode)
1184          (current-buffer)))))
1185
1186 (defun sepia-scratch-send-line (&optional scalarp)
1187   "Send the current line to perl, and display the result."
1188   (interactive "P")
1189   (insert "\n"
1190    (format "%S" (sepia-eval-raw (concat "scalar do{"
1191                        (buffer-substring (sepia-bol-from (point))
1192                                          (sepia-eol-from (point)))
1193                        "}")))
1194    "\n"))
1195
1196 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1197 ;; Miscellany
1198
1199 (defun sepia-string-count-matches (reg str)
1200   (let ((n 0)
1201         (pos -1))
1202     (while (setq pos (string-match reg str (1+ pos)))
1203       (incf n))
1204     n))
1205
1206 (defun sepia-perlize-region-internal (pre post beg end replace-p)
1207   "Pass buffer text from BEG to END through a Perl command."
1208   (let* ((exp (concat pre "<<'SEPIA_END_REGION';\n"
1209                       (buffer-substring-no-properties beg end)
1210                       (if (= (char-before end) ?\n) "" "\n")
1211                       "SEPIA_END_REGION\n" post))
1212          (new-str (car (sepia-eval-raw exp))))
1213     (if replace-p
1214         (progn (delete-region beg end)
1215                (goto-char beg)
1216                (insert new-str))
1217         (if (> (sepia-string-count-matches "\n" new-str) 2)
1218             (with-current-buffer (get-buffer-create "*sepia-filter*")
1219               (let ((inhibit-read-only t))
1220                 (erase-buffer)
1221                 (insert new-str)
1222                 (goto-char (point-min))
1223                 (pop-to-buffer (current-buffer))))
1224             (message "%s" new-str)))))
1225
1226 (defun sepia-eol-from (pt &optional n)
1227   (save-excursion
1228     (goto-char pt)
1229     (end-of-line n)
1230     (point)))
1231
1232 (defun sepia-bol-from (pt &optional n)
1233   (save-excursion
1234     (goto-char pt)
1235     (beginning-of-line n)
1236     (point)))
1237
1238 (defun sepia-perl-pe-region (expr beg end &optional replace-p)
1239   "Do the equivalent of perl -pe on region
1240
1241 \(i.e. evaluate an expression on each line of region).  With
1242 prefix arg, replace the region with the result."
1243   (interactive "MExpression: \nr\nP")
1244   (sepia-perlize-region-internal
1245    "do { my $ret=''; local $_; local $/ = \"\\n\"; my $region = "
1246    (concat "; for (split /(?<=\\n)/, $region, -1) { " expr
1247            "} continue { $ret.=$_}; $ret}")
1248    (sepia-bol-from beg) (sepia-eol-from end) replace-p))
1249
1250 (defun sepia-perl-ne-region (expr beg end &optional replace-p)
1251   "Do the moral equivalent of perl -ne on region
1252
1253 \(i.e. evaluate an expression on each line of region).  With
1254 prefix arg, replace the region with the result."
1255   (interactive "MExpression:\nr\nP")
1256   (sepia-perlize-region-internal
1257    "do { my $ret='';my $region = "
1258    (concat "; for (split /(?<=\\n)/, $region, -1) { $ret .= do { " expr
1259            ";} }; ''.$ret}")
1260    (sepia-bol-from beg) (sepia-eol-from end) replace-p))
1261
1262 (defun sepia-perlize-region (expr beg end &optional replace-p)
1263   "Evaluate a Perl expression on the region as a whole.
1264
1265 With prefix arg, replace the region with the result."
1266   (interactive "MExpression:\nr\nP")
1267   (sepia-perlize-region-internal
1268    "do { local $_ = " (concat "; do { " expr ";}; $_ }") beg end replace-p))
1269
1270 (defun sepia-core-version (module &optional message)
1271   "Report the first version of Perl shipping with MODULE."
1272   (interactive (list (sepia-interactive-arg 'module) t))
1273   (let* ((version
1274           (sepia-eval
1275            (format "eval { Sepia::core_version('%s') }" module)
1276            'scalar-context))
1277          (res (if version
1278                   (format "%s was first released in %s." module version)
1279                   (format "%s is not in core." module))))
1280     (when message (message "%s" res))
1281     res))
1282
1283 (defun sepia-guess-package (sub &optional file)
1284   "Guess which package SUB is defined in."
1285   (let ((defs (xref-location (xref-apropos sub))))
1286     (or (and (= (length defs) 1)
1287              (or (not file) (equal (caar defs) file))
1288              (fourth (car defs)))
1289         (and file
1290              (fourth (find-if (lambda (x) (equal (car x) file)) defs)))
1291         ;; (car (xref-file-modules file))
1292         (sepia-buffer-package))))
1293
1294 ;;;###autoload
1295 (defun sepia-eval-defun ()
1296   "Re-evaluate the current function and rebuild its Xrefs."
1297   (interactive)
1298   (let (pt end beg sub res
1299            sepia-eval-package
1300            sepia-eval-file
1301            sepia-eval-line)
1302     (save-excursion
1303       (setq pt (point)
1304             end (progn (end-of-defun) (point))
1305             beg (progn (beginning-of-defun) (point)))
1306       (goto-char beg)
1307       (when (looking-at "^sub\\s +\\(.+\\_>\\)")
1308         (setq sub (match-string 1))
1309         (let ((body (buffer-substring-no-properties beg end)))
1310
1311           (setq sepia-eval-package (sepia-guess-package sub (buffer-file-name))
1312                 sepia-eval-file (buffer-file-name)
1313                 sepia-eval-line (line-number-at-pos beg)
1314                 res
1315                 (sepia-eval-raw
1316                  (if sepia-eval-defun-include-decls
1317                      (concat
1318                       (apply #'concat (xref-mod-decls sepia-eval-package))
1319                       body)
1320                      body))))))
1321     (if (cdr res)
1322         (progn
1323           (when (string-match " line \\([0-9]+\\), near \"\\([^\"]*\\)\""
1324                               (cdr res))
1325             (goto-char beg)
1326             (beginning-of-line (string-to-number (match-string 1 (cdr res))))
1327             (search-forward (match-string 2 (cdr res))
1328                             (sepia-eol-from (point)) t))
1329           (message "Error: %s" (cdr res)))
1330         (xref-redefined sub sepia-eval-package)
1331         (message "Defined %s" sub))))
1332
1333 ;;;###autoload
1334 (defun sepia-eval-expression (expr &optional list-p message-p)
1335   "Evaluate EXPR in scalar context."
1336   (interactive (list (read-string "Expression: ") current-prefix-arg t))
1337   (let ((res (sepia-eval expr (if list-p 'list-context 'scalar-context))))
1338     (when message-p (message "%s" res))
1339     res))
1340
1341 (defun sepia-extract-def (file line obj)
1342   (with-current-buffer (find-file-noselect (expand-file-name file))
1343     (save-excursion
1344       (funcall (sepia-refiner 'function) line obj)
1345       (beginning-of-line)
1346       (when (looking-at (concat "^\\s *sub\\_>.*\\_<" obj "\\_>"))
1347         (buffer-substring (point)
1348                           (progn (end-of-defun) (point)))))))
1349
1350 (defun sepia-eval-no-run (string)
1351   (let ((res (sepia-eval-raw
1352               (concat "eval q#{ BEGIN { use B; B::minus_c(); $^C=1; } do { "
1353                       string
1354                       " };BEGIN { die \"ok\\n\" }#, $@"))))
1355     (if (string-match "^ok\n" (car res))
1356         nil
1357         (car res))))
1358
1359 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1360 ;; REPL
1361
1362 (defvar sepia-eval-file nil
1363   "File in which `sepia-eval' evaluates perl expressions.")
1364 (defvar sepia-eval-line nil
1365   "Line at which `sepia-eval' evaluates perl expressions.")
1366
1367 (defun sepia-set-cwd (dir)
1368   "Set the inferior Perl process's working directory to DIR.
1369
1370 When called interactively, the current buffer's
1371 `default-directory' is used."
1372   (interactive (list (expand-file-name default-directory)))
1373   (sepia-call "Cwd::chdir" 'list-context dir))
1374
1375 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1376 ;; Doc-scanning
1377
1378 (defvar sepia-doc-map (make-hash-table :test #'equal))
1379 (defvar sepia-var-doc-map (make-hash-table :test #'equal))
1380 (defvar sepia-module-doc-map (make-hash-table :test #'equal))
1381
1382 (defun sepia-doc-scan-buffer ()
1383   (save-excursion
1384     (goto-char (point-min))
1385     (loop
1386        while (re-search-forward
1387                  "^=\\(item\\|head[2-9]\\)\\s +\\([%$&@A-Za-z_].*\\)" nil t)
1388        if
1389          (ignore-errors
1390            (let ((short (match-string 2)) longdoc)
1391               (setq short
1392                     (let ((case-fold-search nil))
1393                       (replace-regexp-in-string
1394                        "E<lt>" "<"
1395                        (replace-regexp-in-string
1396                         "E<gt>" ">"
1397                         (replace-regexp-in-string
1398                          "[A-DF-Z]<\\([^<>]+\\)>" "\\1" short)))))
1399               (while (string-match "^\\s *[A-Z]<\\(.*\\)>\\s *$" short)
1400                 (setq short (match-string 1 short)))
1401               (setq longdoc
1402                     (let ((beg (progn (forward-line 2) (point)))
1403                           (end (1- (re-search-forward "^=" nil t))))
1404                       (forward-line -1)
1405                       (goto-char beg)
1406                       (if (re-search-forward "^\\(.+\\)$" end t)
1407                           (concat short ": "
1408                                   (substring-no-properties
1409                                    (match-string 1)
1410                                    0 (position ?. (match-string 1))))
1411                           short)))
1412               (cond
1413                 ;; e.g. "$x -- this is x"
1414                 ((string-match "^[%$@]\\([A-Za-z0-9_:]+\\)\\s *--\\s *\\(.*\\)"
1415                                short)
1416                  (list 'variable (match-string-no-properties 1 short)
1417                        (or (and (equal short (match-string 1 short)) longdoc)
1418                            short)))
1419                 ;; e.g. "C<foo(BLAH)>" or "$x = $y->foo()"
1420                 ((string-match "\\([A-Za-z0-9_:]+\\)\\s *\\(\\$\\|(\\)" short)
1421                  (list 'function (match-string-no-properties 1 short)
1422                        (or (and (equal short (match-string 1 short)) longdoc)
1423                            short)))
1424                 ;; e.g. "C<$result = foo $args...>"
1425                 ((string-match "=\\s *\\([A-Za-z0-9_:]+\\)" short)
1426                  (list 'function (match-string-no-properties 1 short)
1427                        (or (and (equal short (match-string 1 short)) longdoc)
1428                            short)))
1429                 ;; e.g. "$x this is x" (note: this has to come last)
1430                 ((string-match "^[%$@]\\([^( ]+\\)" short)
1431                  (list 'variable (match-string-no-properties 1 short) longdoc)))))
1432        collect it)))
1433
1434 (defun sepia-buffer-package ()
1435   (save-excursion
1436     (or (and (re-search-backward "^\\s *package\\s +\\([^ ;]+\\)\\s *;" nil t)
1437              (match-string-no-properties 1))
1438         "main")))
1439
1440 (defun sepia-doc-update ()
1441   "Update documentation for a file.
1442
1443 This documentation, taken from \"=item\" entries in the POD, is
1444 used for eldoc feedback."
1445   (interactive)
1446   (let ((pack (ifa (sepia-buffer-package) (concat it "::") "")))
1447     (dolist (x (sepia-doc-scan-buffer))
1448       (let ((map (ecase (car x)
1449                    (function sepia-doc-map)
1450                    (variable sepia-var-doc-map))))
1451         (puthash (second x) (third x) map)
1452         (puthash (concat pack (second x)) (third x) map)))))
1453
1454 (defun sepia-looks-like-module (obj)
1455   (let (case-fold-search)
1456     (or (string-match "^\\([A-Z][A-Za-z0-9]+::\\)*[A-Z]+[A-Za-z0-9]+\\sw*$" obj)
1457         (string-match
1458          (eval-when-compile (regexp-opt '("strict" "vars" "warnings" "lib")))
1459          obj))))
1460
1461 (defun sepia-symbol-info (&optional obj type)
1462   "Eldoc function for Sepia-mode.
1463
1464 Looks in `sepia-doc-map' and `sepia-var-doc-map', then tries
1465 calling `cperl-describe-perl-symbol'."
1466   (unless obj
1467     (multiple-value-bind (ty ob) (sepia-ident-at-point)
1468       (setq obj (if (consp ob) (car ob) ob)
1469             type ty)))
1470   (if obj
1471       (or (gethash obj (ecase (or type ?&)
1472                          (?& sepia-doc-map)
1473                          ((?$ ?@ ?%) sepia-var-doc-map)
1474                          (nil sepia-module-doc-map)
1475                          (?* sepia-module-doc-map)
1476                          (t (error "sepia-symbol-info: %s" type))))
1477           ;; Loathe cperl a bit.
1478           (flet ((message (&rest blah) (apply #'format blah)))
1479             (let* (case-fold-search
1480                    (cperl-message-on-help-error nil)
1481                    (hlp (car (save-excursion (cperl-describe-perl-symbol obj)))))
1482               (if hlp
1483                   (progn
1484                     ;; cperl's docstrings are too long.
1485                     (setq hlp (replace-regexp-in-string "\\s \\{2,\\}" "  " hlp))
1486                     (if (> (length hlp) 75)
1487                         (concat (substring hlp 0 72) "...")
1488                         hlp))
1489                   ;; Try to see if it's a module
1490                   (if (and
1491                        (let ((bol (save-excursion (beginning-of-line)
1492                                                   (point))))
1493                          (looking-back " *\\(?:use\\|require\\|package\\) +[^ ]+" bol))
1494                        (sepia-looks-like-module obj))
1495                       (sepia-core-version obj)
1496                       ""))))
1497       "")))
1498
1499 (defun sepia-install-eldoc ()
1500   "Install Sepia hooks for eldoc support."
1501   (interactive)
1502   (require 'eldoc)
1503   (set-variable 'eldoc-documentation-function 'sepia-symbol-info t)
1504   (if cperl-lazy-installed (cperl-lazy-unstall))
1505   (eldoc-mode 1)
1506   (set-variable 'eldoc-idle-delay 1.0 t))
1507
1508 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1509 ;; Error jump:
1510
1511 (defun sepia-extract-next-warning (pos &optional end)
1512   (catch 'foo
1513     (while (re-search-forward "^\\(.+\\) at \\(.+?\\) line \\([0-9]+\\)"
1514                               end t)
1515       (unless (string= "(eval " (substring (match-string 2) 0 6))
1516         (throw 'foo (list (match-string 2)
1517                           (string-to-number (match-string 3))
1518                           (match-string 1)))))))
1519
1520 (defun sepia-goto-error-at (pos)
1521   "Visit the source of the error on line at point."
1522   (interactive "d")
1523   (ifa (sepia-extract-next-warning (sepia-bol-from pos) (sepia-eol-from pos))
1524        (destructuring-bind (file line msg) it
1525          (find-file file)
1526          (goto-line line)
1527          (message "%s" msg))
1528        (error "No error to find.")))
1529
1530 (defun sepia-display-errors (beg end)
1531   "Display source causing errors in current buffer from BEG to END."
1532   (interactive "r")
1533   (goto-char beg)
1534   (let ((msgs nil))
1535     (loop for w = (sepia-extract-next-warning (sepia-bol-from (point)) end)
1536        while w
1537        do (destructuring-bind (file line msg) w
1538             (push (format "%s:%d:%s\n" (abbreviate-file-name file) line msg)
1539                   msgs)))
1540     (erase-buffer)
1541     (goto-char (point-min))
1542     (mapcar #'insert (nreverse msgs))
1543     (goto-char (point-min))
1544     (grep-mode)))
1545
1546 (defun sepia-lisp-to-perl (thing)
1547   "Convert elisp data structure to Perl."
1548   (cond
1549     ((null thing) "undef")
1550     ((symbolp thing)
1551      (let ((pname (substitute ?_ ?- (symbol-name thing)))
1552            (type (string-to-char (symbol-name thing))))
1553        (if (member type '(?% ?$ ?@ ?*))
1554            pname
1555            (concat "\\*" pname))))
1556     ((stringp thing) (format "%S" (substring-no-properties thing 0)))
1557     ((integerp thing) (format "%d" thing))
1558     ((numberp thing) (format "%g" thing))
1559     ;; Perl expression
1560     ((and (consp thing) (eq (car thing) 'expr))
1561      (cdr thing))        ; XXX -- need quoting??
1562     ((and (consp thing) (not (consp (cdr thing))))
1563      (concat (sepia-lisp-to-perl (car thing)) " => "
1564              (sepia-lisp-to-perl (cdr thing))))
1565     ;; list
1566     ((or (not (consp (car thing)))
1567          (listp (cdar thing)))
1568      (concat "[" (mapconcat #'sepia-lisp-to-perl thing ", ") "]"))
1569     ;; hash table
1570     (t
1571      (concat "{" (mapconcat #'sepia-lisp-to-perl thing ", ") "}"))))
1572
1573 (defun sepia-init-perl-builtins ()
1574   (setq sepia-perl-builtins (make-hash-table))
1575   (dolist (s '("abs"
1576 "accept"
1577 "alarm"
1578 "atan2"
1579 "bind"
1580 "binmode"
1581 "bless"
1582 "caller"
1583 "chdir"
1584 "chmod"
1585 "chomp"
1586 "chop"
1587 "chown"
1588 "chr"
1589 "chroot"
1590 "close"
1591 "closedir"
1592 "connect"
1593 "continue"
1594 "cos"
1595 "crypt"
1596 "dbmclose"
1597 "dbmopen"
1598 "defined"
1599 "delete"
1600 "die"
1601 "dump"
1602 "each"
1603 "endgrent"
1604 "endhostent"
1605 "endnetent"
1606 "endprotoent"
1607 "endpwent"
1608 "endservent"
1609 "eof"
1610 "eval"
1611 "exec"
1612 "exists"
1613 "exit"
1614 "exp"
1615 "fcntl"
1616 "fileno"
1617 "flock"
1618 "fork"
1619 "format"
1620 "formline"
1621 "getc"
1622 "getgrent"
1623 "getgrgid"
1624 "getgrnam"
1625 "gethostbyaddr"
1626 "gethostbyname"
1627 "gethostent"
1628 "getlogin"
1629 "getnetbyaddr"
1630 "getnetbyname"
1631 "getnetent"
1632 "getpeername"
1633 "getpgrp"
1634 "getppid"
1635 "getpriority"
1636 "getprotobyname"
1637 "getprotobynumber"
1638 "getprotoent"
1639 "getpwent"
1640 "getpwnam"
1641 "getpwuid"
1642 "getservbyname"
1643 "getservbyport"
1644 "getservent"
1645 "getsockname"
1646 "getsockopt"
1647 "glob"
1648 "gmtime"
1649 "goto"
1650 "grep"
1651 "hex"
1652 "import"
1653 "index"
1654 "int"
1655 "ioctl"
1656 "join"
1657 "keys"
1658 "kill"
1659 "last"
1660 "lc"
1661 "lcfirst"
1662 "length"
1663 "link"
1664 "listen"
1665 "local"
1666 "localtime"
1667 "log"
1668 "lstat"
1669 "map"
1670 "mkdir"
1671 "msgctl"
1672 "msgget"
1673 "msgrcv"
1674 "msgsnd"
1675 "next"
1676 "oct"
1677 "open"
1678 "opendir"
1679 "ord"
1680 "pack"
1681 "package"
1682 "pipe"
1683 "pop"
1684 "pos"
1685 "print"
1686 "printf"
1687 "prototype"
1688 "push"
1689 "quotemeta"
1690 "rand"
1691 "read"
1692 "readdir"
1693 "readline"
1694 "readlink"
1695 "readpipe"
1696 "recv"
1697 "redo"
1698 "ref"
1699 "rename"
1700 "require"
1701 "reset"
1702 "return"
1703 "reverse"
1704 "rewinddir"
1705 "rindex"
1706 "rmdir"
1707 "scalar"
1708 "seek"
1709 "seekdir"
1710 "select"
1711 "semctl"
1712 "semget"
1713 "semop"
1714 "send"
1715 "setgrent"
1716 "sethostent"
1717 "setnetent"
1718 "setpgrp"
1719 "setpriority"
1720 "setprotoent"
1721 "setpwent"
1722 "setservent"
1723 "setsockopt"
1724 "shift"
1725 "shmctl"
1726 "shmget"
1727 "shmread"
1728 "shmwrite"
1729 "shutdown"
1730 "sin"
1731 "sleep"
1732 "socket"
1733 "socketpair"
1734 "sort"
1735 "splice"
1736 "split"
1737 "sprintf"
1738 "sqrt"
1739 "srand"
1740 "stat"
1741 "study"
1742 "sub"
1743 "sub*"
1744 "substr"
1745 "symlink"
1746 "syscall"
1747 "sysopen"
1748 "sysread"
1749 "sysseek"
1750 "system"
1751 "syswrite"
1752 "tell"
1753 "telldir"
1754 "tie"
1755 "tied"
1756 "time"
1757 "times"
1758 "truncate"
1759 "uc"
1760 "ucfirst"
1761 "umask"
1762 "undef"
1763 "unlink"
1764 "unpack"
1765 "unshift"
1766 "untie"
1767 "utime"
1768 "values"
1769 "vec"
1770 "wait"
1771 "waitpid"
1772 "wantarray"
1773 "warn"
1774 "write"
1775 ))
1776         (puthash s t sepia-perl-builtins)))
1777
1778 (provide 'sepia)
1779 ;;; sepia.el ends here