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