sepia.el

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