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