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