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