sepia.el

   1 ;;; Sepia -- Simple Emacs-Perl InterAction: ugly, yet effective.
   2 ;;; (a.k.a. Septik -- Sean's Emacs-Perl Total Integration Kludge.)
   3
   4 ;; Copyright (C) 2004-2007 Sean O'Rourke.  All rights reserved, some
   5 ;; wrongs reversed.  This code is distributed under the same terms as
   6 ;; Perl itself.
   7
   8 ;;; Commentary:
   9
  10 ;; Sepia is a set of tools for Perl development in Emacs.  Its goal is
  11 ;; to extend CPerl mode with two contributions: fast code navigation
  12 ;; and interactive development.  It is inspired by Emacs' current
  13 ;; support for a number of other languages, including Lisp, Python,
  14 ;; Ruby, and Emacs Lisp.
  15 ;;
  16 ;; See sepia.texi, which comes with the distribution.
  17
  18 ;;; Code:
  19
  20 (require 'cperl-mode)
  21 (require 'gud)
  22 (require 'cl)
  23 ;; try optional modules, but don't bitch if we fail:
  24 (ignore-errors (require 'sepia-w3m))
  25 (ignore-errors (require 'sepia-tree))
  26 (ignore-errors (require 'sepia-ido))
  27
  28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29 ;;; Comint communication
  30
  31 (defvar sepia-perl5lib nil
  32 "* List of extra PERL5LIB directories for `sepia-repl'.")
  33
  34 (defvar sepia-program-name "perl"
  35 "* Perl program name.")
  36
  37 (defvar sepia-view-pod-function
  38   (if (featurep 'w3m) 'sepia-w3m-view-pod 'sepia-perldoc-buffer)
  39 "* Function to view current buffer's documentation.
  40
  41 Useful values include `sepia-w3m-view-pod' and `sepia-perldoc-buffer'.")
  42
  43 (defvar sepia-module-list-function
  44   (if (featurep 'w3m) 'w3m-find-file 'browse-url-of-buffer)
  45 "* Function to view a list of installed modules.
  46
  47 Useful values include `w3m-find-file' and `browse-url-of-buffer'.")
  48
  49 (defvar sepia-complete-methods t
  50 "* Non-nil if Sepia should try to complete methods for \"$x->\".
  51
  52 NOTE: this feature can be problematic, since it evaluates the
  53 object in order to find its type.  Currently completion is only
  54 attempted for objects that are simple scalars.")
  55
  56 (defvar sepia-indent-expand-abbrev t
  57 "* If non-NIL, `sepia-indent-or-complete' tries `expand-abbrev'.")
  58
  59 (defvar sepia-use-completion t
  60   "* Use completion based on Xref database.
  61
  62 Turning this off may speed up some operations, if you don't mind
  63 losing completion.")
  64
  65 (defvar sepia-eval-defun-include-decls t
  66   "* Generate and use a declaration list for `sepia-eval-defun'.
  67 Without this, code often will not parse; with it, evaluation may
  68 be a bit less responsive.  Note that since this only includes
  69 subs from the evaluation package, it may not always work.")
  70
  71 (defvar sepia-prefix-key "\M-."
  72   "* Prefix for functions in `sepia-keymap'.")
  73
  74 ;;; User options end here.
  75
  76 (defvar sepia-process nil
  77 "The perl process with which we're interacting.")
  78 (defvar sepia-output nil
  79 "Current perl output for a response to `sepia-eval-raw', appended
  80 to by `perl-collect-output'.")
  81 (defvar sepia-passive-output ""
  82 "Current perl output for miscellaneous user interaction, used to
  83 look for \";;;###\" lisp evaluation markers.")
  84
  85 (defvar sepia-perl-builtins nil
  86 "List of Perl builtins for completion.")
  87
  88 (defun sepia-collect-output (string)
  89 "Collect perl output for `sepia-eval-raw' into sepia-output."
  90   (setq sepia-output (concat sepia-output string))
  91   "")
  92
  93 (defun sepia-eval-raw (str)
  94   "Evaluate perl code STR, returning a pair (RESULT-STRING . OUTPUT)."
  95   (sepia-ensure-process)
  96   (let (ocpof)
  97     (unwind-protect
  98          (let ((sepia-output "")
  99                (start 0))
 100            (with-current-buffer (process-buffer sepia-process)
 101              (setq ocpof comint-preoutput-filter-functions
 102                    comint-preoutput-filter-functions
 103                    '(sepia-collect-output)))
 104            (setq str (concat "local $Sepia::STOPDIE=0;"
 105                              "local $Sepia::STOPWARN=0;"
 106                              "{ package " (sepia-buffer-package) ";"
 107                              str " }\n"))
 108            (comint-send-string sepia-process
 109                                (concat (format "<<%d\n" (length str)) str))
 110            (while (not (and sepia-output
 111                             (string-match "> $" sepia-output)))
 112              (accept-process-output sepia-process))
 113            (if (string-match "^;;;[0-9]+\n" sepia-output)
 114                (cons
 115                 (let* ((x (read-from-string sepia-output
 116                                             (+ (match-beginning 0) 3)))
 117                        (len (car x))
 118                        (pos (cdr x)))
 119                   (prog1 (substring sepia-output (1+ pos) (+ len pos 1))
 120                     (setq start (+ pos len 1))))
 121                 (and (string-match ";;;[0-9]+\n" sepia-output start)
 122                      (let* ((x (read-from-string
 123                                 sepia-output
 124                                 (+ (match-beginning 0) 3)))
 125                             (len (car x))
 126                             (pos (cdr x)))
 127                        (substring sepia-output (1+ pos) (+ len pos 1)))))
 128                (cons sepia-output nil)))
 129       (with-current-buffer (process-buffer sepia-process)
 130         (setq comint-preoutput-filter-functions ocpof)))))
 131
 132 (defun sepia-eval (str &optional context detailed)
 133 "Evaluate STR in CONTEXT (void by default), and return its result
 134 as a Lisp object.  If DETAILED is specified, return a
 135 pair (RESULT . OUTPUT)."
 136   (let* ((tmp (sepia-eval-raw
 137                (case context
 138                  (list-context
 139                   (concat "Sepia::tolisp([" str "])"))
 140                  (scalar-context
 141                   (concat "Sepia::tolisp(scalar(" str "))"))
 142                  (t (concat str ";1")))))
 143          (res (car tmp))
 144          (errs (cdr tmp)))
 145     (setq res (if context
 146                   (if (string= res "") "" (car (read-from-string res)))
 147                   1))
 148     (if detailed
 149         (cons res errs)
 150         res)))
 151
 152 (defun sepia-call (fn context &rest args)
 153 "Call perl function FN in CONTEXT with arguments ARGS, returning
 154 its result as a Lisp value."
 155   (sepia-eval (concat fn "(" (mapconcat #'sepia-lisp-to-perl args ", ") ")")
 156               context))
 157
 158 (defun sepia-watch-for-eval (string)
 159 "Monitor inferior Perl output looking for Lisp evaluation
 160 requests.  The format for these requests is
 161 \"\\n;;;###LENGTH\\nDATA\".  Only one such request can come from
 162 each inferior Perl prompt."
 163   (setq sepia-passive-output (concat sepia-passive-output string))
 164   (cond
 165     ((string-match "^;;;###[0-9]+" sepia-passive-output)
 166      (if (string-match "^;;;###\\([0-9]+\\)\n\\(?:.\\|\n\\)*\n\\(.*> \\)"
 167                          sepia-passive-output)
 168        (let* ((len (car (read-from-string
 169                          (match-string 1 sepia-passive-output))))
 170               (pos (1+ (match-end 1)))
 171               (res (ignore-errors (eval (car (read-from-string
 172                                               sepia-passive-output pos
 173                                               (+ pos len)))))))
 174          (message "%s => %s"
 175                   (substring sepia-passive-output pos (+ pos len)) res)
 176          (goto-char (point-max))
 177          (insert (substring sepia-passive-output (+ 1 pos len)))
 178          (set-marker (process-mark (get-buffer-process (current-buffer)))
 179                      (point))
 180          (setq sepia-passive-output ""))
 181        ""))
 182     (t (setq sepia-passive-output "") string)))
 183
 184
 185 (defvar sepia-metapoint-map
 186   (let ((map (make-sparse-keymap)))
 187     (when (featurep 'ido)
 188       (define-key map "j" 'sepia-jump-to-symbol))
 189     (dolist (kv '(("c" . sepia-callers)
 190                   ("C" . sepia-callees)
 191                   ("a" . sepia-apropos)
 192                   ("A" . sepia-var-apropos)
 193                   ("v" . sepia-var-uses)
 194                   ("V" . sepia-var-defs)
 195                   ;;              ("V" . sepia-var-assigns)
 196                   ("\M-." . sepia-dwim)
 197                   ;; ("\M-." . sepia-location)
 198                   ("l" . sepia-location)
 199                   ("f" . sepia-defs)
 200                   ("r" . sepia-rebuild)
 201                   ("m" . sepia-module-find)
 202                   ("n" . sepia-next)
 203                   ("t" . find-tag)
 204                   ("d" . sepia-perldoc-this)))
 205       (define-key map (car kv) (cdr kv)))
 206     map)
 207   "Keymap for Sepia functions.  This is just an example of how you
 208 might want to bind your keys, which works best when bound to
 209 `\\M-.'.")
 210
 211 (defvar sepia-shared-map
 212   (let ((map (make-sparse-keymap)))
 213     (define-key map sepia-prefix-key sepia-metapoint-map)
 214     (define-key map "\M-," 'sepia-next)
 215     (define-key map "\C-\M-x" 'sepia-eval-defun)
 216     (define-key map "\C-c\C-l" 'sepia-load-file)
 217     (define-key map "\C-c\C-d" 'sepia-view-pod)
 218     (define-key map "\C-c\C-r" 'sepia-repl)
 219     (define-key map "\C-c\C-s" 'sepia-scratch)
 220     (define-key map "\C-c\C-e" 'sepia-eval-expression)
 221     (define-key map "\C-c!" 'sepia-set-cwd)
 222     (define-key map (kbd "TAB") 'sepia-indent-or-complete)
 223     map)
 224   "Sepia bindings common to all modes.")
 225
 226 ;;;###autoload
 227 (defun sepia-perldoc-this (name)
 228   "View perldoc for module at point."
 229   (interactive (list (sepia-interactive-arg 'module)))
 230   (let ((wc (current-window-configuration))
 231         (old-pd (symbol-function 'w3m-about-perldoc))
 232         (old-pdb (symbol-function 'w3m-about-perldoc-buffer)))
 233     (condition-case stuff
 234         (flet ((w3m-about-perldoc (&rest args)
 235                  (let ((res (apply old-pd args)))
 236                    (or res (error "lose: %s" args))))
 237                (w3m-about-perldoc-buffer (&rest args)
 238                  (let ((res (apply old-pdb args)))
 239                    (or res (error "lose: %s" args)))))
 240           (funcall (if (featurep 'w3m) 'w3m-perldoc 'cperl-perldoc) name))
 241       (error (set-window-configuration wc)))))
 242
 243 (defun sepia-view-pod ()
 244   "View POD for the current buffer."
 245   (interactive)
 246   (funcall sepia-view-pod-function))
 247
 248 (defun sepia-module-list ()
 249   "List installed modules with links to their documentation.
 250
 251 This lists not just top-level packages appearing in packlist
 252 files, but all documented modules on the system, organized by
 253 package."
 254   (interactive)
 255   (let ((file "/tmp/modlist.html"))
 256     ;; (unless (file-exists-p file)
 257     (sepia-eval-raw (format "Sepia::html_module_list(\"%s\")" file))
 258     (funcall sepia-module-list-function file)))
 259
 260 (defun sepia-package-list ()
 261   "List installed packages with links to their documentation.
 262
 263 This lists only top-level packages appearing in packlist files.
 264 For modules within packages, see `sepia-module-list'."
 265   (interactive)
 266   (let ((file "/tmp/packlist.html"))
 267     ;; (unless (file-exists-p file)
 268     (sepia-eval-raw (format "Sepia::html_package_list(\"%s\")" file))
 269     (funcall sepia-module-list-function file)))
 270
 271 (defun sepia-perldoc-buffer ()
 272   "View current buffer's POD using pod2html and `browse-url'."
 273   (let ((buffer (get-buffer-create "*sepia-pod*"))
 274         (errs (get-buffer-create "*sepia-pod-errors*"))
 275         (inhibit-read-only t))
 276     (with-current-buffer buffer (erase-buffer))
 277     (save-window-excursion
 278       (shell-command-on-region (point-min) (point-max) "pod2html"
 279                                buffer nil errs))
 280     (with-current-buffer buffer (browse-url-of-buffer))))
 281
 282 (defun sepia-perl-name (sym &optional mod)
 283 "Convert a Perl name to a Lisp name."
 284   (setq sym (substitute ?_ ?- (if (symbolp sym) (symbol-name sym) sym)))
 285   (if mod
 286       (concat mod "::" sym)
 287       sym))
 288
 289 (defun sepia-live-p ()
 290   (and (processp sepia-process)
 291        (eq (process-status sepia-process) 'run)))
 292
 293 (defun sepia-ensure-process (&optional remote-host)
 294   (unless (sepia-live-p)
 295     (with-current-buffer (get-buffer-create "*sepia-repl*")
 296       (sepia-repl-mode)
 297       (set (make-local-variable 'sepia-passive-output) ""))
 298     (if remote-host
 299         (comint-exec "*sepia-repl*" "attachtty" "attachtty" nil
 300                      (list remote-host))
 301         (let ((stuff (split-string sepia-program-name nil t)))
 302           (comint-exec (get-buffer-create "*sepia-repl*")
 303                        "perl" (car stuff) nil
 304                        (append
 305                         (cdr stuff)
 306                         (mapcar (lambda (x) (concat "-I" x)) sepia-perl5lib)
 307                         '("-MSepia" "-MSepia::Xref"
 308                           "-e" "Sepia::repl")))))
 309     (setq sepia-process (get-buffer-process "*sepia-repl*"))
 310     (accept-process-output sepia-process 0 1)
 311     ;; Steal a bit from gud-common-init:
 312     (setq gud-running t)
 313     (setq gud-last-last-frame nil)
 314     (set-process-filter sepia-process 'gud-filter)
 315     (set-process-sentinel sepia-process 'gud-sentinel)))
 316
 317 ;;;###autoload
 318 (defun sepia-repl (&optional remote-host)
 319   "Start the Sepia REPL."
 320   (interactive (list (and current-prefix-arg
 321                           (read-string "Host: "))))
 322   (sepia-init) ;; set up keymaps, etc.
 323   (sepia-ensure-process remote-host)
 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 (defalias 'sepia-package-defs 'sepia-module-describe)
 585
 586 (define-sepia-query sepia-apropos
 587     "Find/list subroutines matching regexp."
 588   (lambda (name &rest blah) (xref-apropos name 1))
 589   xref-location
 590   'function)
 591
 592 (define-sepia-query sepia-var-apropos
 593     "Find/list variables matching regexp."
 594   xref-var-apropos
 595   xref-var-defs
 596   'variable)
 597
 598 (defun sepia-location (name &optional jump-to)
 599   "Find the definition of NAME.
 600
 601 When called interactively (or with JUMP-TO true), go directly
 602 to this location."
 603   (interactive (list (sepia-interactive-arg 'function) t))
 604   (let* ((fl (or (car (xref-location name))
 605                  (car (remove-if #'null
 606                                  (apply #'xref-location (xref-apropos name)))))))
 607     (when (and (car fl) (string-match "^(eval " (car fl)))
 608       (message "Can't find definition of %s in %s." name (car fl))
 609       (setq fl nil))
 610     (if jump-to
 611         (if fl (progn
 612                  (sepia-set-found (list fl) 'function)
 613                  (sepia-next))
 614             (message "No definition for %s." name))
 615         fl)))
 616
 617 ;;;###autoload
 618 (defun sepia-dwim (&optional display-p)
 619     "Try to do the right thing with identifier at point.
 620 * Find all definitions, if thing-at-point is a function
 621 * Find all uses, if thing-at-point is a variable
 622 * Find documentation, if thing-at-point is a module
 623 * Prompt otherwise
 624 "
 625     (interactive "P")
 626     (multiple-value-bind (type obj) (sepia-ident-at-point)
 627       (sepia-set-found nil type)
 628       (let* ((module-doc-p nil)
 629              (ret
 630               (cond
 631                 ((member type '(?% ?$ ?@)) (xref-var-defs obj))
 632                 ((or (equal type ?&)
 633                      (let (case-fold-search)
 634                        (string-match "^[^A-Z]" obj)))
 635                  (list (sepia-location obj)))
 636                 ((sepia-looks-like-module obj)
 637                  (setq module-doc-p t)
 638                  `((,(sepia-perldoc-this obj) 1 nil nil)))
 639                 (t (setq module-doc-p t)
 640                    (call-interactively 'sepia-defs)))))
 641         (unless module-doc-p
 642           (if display-p
 643               (sepia-show-locations ret)
 644               (sepia-set-found ret type)
 645               (sepia-next))))))
 646
 647 (defun sepia-rebuild ()
 648   "Rebuild the Xref database."
 649   (interactive)
 650   (xref-rebuild))
 651
 652 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 653 ;;; Perl motion commands.
 654
 655 ;;; XXX -- these are a hack to prevent infinite recursion calling
 656 ;;; e.g. beginning-of-defun from beginning-of-defun-function.
 657 ;;; `beginning-of-defun' should handle this.
 658 (defmacro sepia-safe-bodf (&optional n)
 659   `(let ((beginning-of-defun-function
 660           (if (and (boundp 'beginning-of-defun-function)
 661                    (eq beginning-of-defun-function 'sepia-beginning-of-defun))
 662               nil
 663               beginning-of-defun-function)))
 664      (beginning-of-defun ,n)))
 665
 666 (defmacro sepia-safe-eodf (&optional n)
 667   `(let ((end-of-defun-function
 668           (if (and (boundp 'end-of-defun-function)
 669                    (eq end-of-defun-function 'sepia-end-of-defun))
 670               nil
 671               end-of-defun-function)))
 672      (end-of-defun ,n)))
 673
 674 (defun sepia-beginning-of-defun (&optional n)
 675 "Move to beginning of current function.
 676
 677 The prefix argument is the same as for `beginning-of-defun'."
 678   (interactive "p")
 679   (setq n (or n 1))
 680   (ignore-errors
 681     (when (< n 0)
 682       (sepia-end-of-defun (- n))
 683       (setq n 1))
 684     (re-search-backward sepia-sub-re nil nil n)))
 685
 686 (defun sepia-inside-defun ()
 687   "True if point is inside a sub."
 688   (condition-case nil
 689       (save-excursion
 690         (let ((cur (point)))
 691           (re-search-backward sepia-sub-re)
 692           (when (< (point) cur)
 693             (search-forward "{")
 694             (backward-char 1)
 695             (forward-sexp)
 696             (> (point) cur))))
 697     (error nil)))
 698
 699 (defun sepia-end-of-defun (&optional n)
 700   "Move to end of current function.
 701
 702 The prefix argument is the same as for `end-of-defun'."
 703   (interactive "p")
 704   (setq n (or n 1))
 705   (when (< n 0)
 706     (sepia-beginning-of-defun (- n))
 707     (setq n 1))
 708   ;; If we're outside a defun, skip to the next
 709   (ignore-errors
 710     (unless (sepia-inside-defun)
 711       (re-search-forward sepia-sub-re)
 712       (forward-char 1))
 713     (dotimes (i n)
 714       (re-search-backward sepia-sub-re)
 715       (search-forward "{")
 716       (backward-char 1)
 717       (forward-sexp))
 718     (point)))
 719
 720 (defun sepia-defun-around-point (&optional where)
 721   "Return the text of function around point."
 722   (unless where
 723     (setq where (point)))
 724   (save-excursion
 725     (goto-char where)
 726     (and (sepia-beginning-of-defun)
 727          (match-string-no-properties 1))))
 728
 729 (defun sepia-lexicals-at-point (&optional where)
 730   "Find lexicals in scope at point."
 731   (interactive "d")
 732   (unless where
 733     (setq where (point)))
 734   (let ((subname (sepia-defun-around-point where))
 735         (mod (sepia-buffer-package)))
 736     (xref-lexicals (sepia-perl-name subname mod))))
 737
 738 ;;;###autoload
 739 (defun sepia-load-file (file &optional rebuild-p collect-warnings)
 740   "Reload a file (interactively, the current buffer's file).
 741
 742 With REBUILD-P (or a prefix argument when called interactively),
 743 also rebuild the xref database."
 744   (interactive (list (expand-file-name (buffer-file-name))
 745                      prefix-arg
 746                      (format "*%s errors*" (buffer-file-name))))
 747   (save-buffer)
 748   (when collect-warnings
 749     (let (kill-buffer-query-functions)
 750       (ignore-errors
 751         (kill-buffer collect-warnings))))
 752   (let* ((tmp (sepia-eval (format "do '%s' || ($@ && do { local $Sepia::Debug::STOPDIE; die $@ })" file)
 753                           'scalar-context t))
 754          (res (car tmp))
 755          (errs (cdr tmp)))
 756     (message "sepia: %s returned %s" (abbreviate-file-name file) res)
 757     (when (and collect-warnings
 758                (> (length errs) 1))
 759       (with-current-buffer (get-buffer-create collect-warnings)
 760         (let ((inhibit-read-only t))
 761           (delete-region (point-min) (point-max))
 762           (insert errs)
 763           (sepia-display-errors (point-min) (point-max))
 764           (pop-to-buffer (current-buffer))))))
 765   (when rebuild-p
 766     (xref-rebuild)))
 767
 768 (defvar sepia-found)
 769
 770 (defun sepia-set-found (list &optional type)
 771   (setq list
 772         (remove-if (lambda (x)
 773                      (or (not x)
 774                          (and (not (car x)) (string= (fourth x) "main"))))
 775                    list))
 776   (setq sepia-found (cons -1 list))
 777   (setq sepia-found-refiner (sepia-refiner type)))
 778
 779 (defun sepia-refiner (type)
 780   (case type
 781     (function
 782      (lambda (line ident)
 783       (let ((sub-re (concat "^\\s *sub\\s +.*" ident "\\_>")))
 784         ;; Test this because sometimes we get lucky and get the line
 785         ;; just right, in which case beginning-of-defun goes to the
 786         ;; previous defun.
 787           (or (and line
 788                    (progn
 789                      (goto-line line)
 790                      (beginning-of-defun)
 791                      (looking-at sub-re)))
 792               (progn (goto-char (point-min))
 793                      (re-search-forward sub-re nil t)))
 794           (beginning-of-line))))
 795     ;; Old version -- this may actually work better if
 796     ;; beginning-of-defun goes flaky on us.
 797 ;;         (or (re-search-backward sub-re
 798 ;;                                 (sepia-bol-from (point) -20) t)
 799 ;;             (re-search-forward sub-re
 800 ;;                                (sepia-bol-from (point) 10) t))
 801 ;;         (beginning-of-line)
 802     (variable
 803      (lambda (line ident)
 804        (let ((var-re (concat "\\_<" ident "\\_>")))
 805          (cond
 806            (line (goto-line line)
 807                  (or (re-search-backward var-re (sepia-bol-from (point) -5) t)
 808                      (re-search-forward var-re (sepia-bol-from (point) 5) t)))
 809            (t (goto-char (point-min))
 810               (re-search-forward var-re nil t))))))
 811     (t (lambda (line ident) (and line (goto-line line))))))
 812
 813 (defun sepia-next (&optional arg)
 814   "Go to the next thing (e.g. def, use) found by sepia."
 815   (interactive "p")
 816   (or arg (setq arg 1))
 817   (if (cdr sepia-found)
 818       (let ((i (car sepia-found))
 819             (list (cdr sepia-found))
 820             (len (length (cdr sepia-found)))
 821             (next (+ (car sepia-found) arg))
 822             (prompt ""))
 823         (if (and (= len 1) (>= i 0))
 824             (message "No more definitions.")
 825           ;; if stepwise found next or previous item, it can cycle
 826           ;; around the `sepia-found'. When at first or last item, get
 827           ;; a warning
 828           (if (= (abs arg) 1)
 829               (progn
 830                 (setq i next)
 831                 (if (< i 0)
 832                     (setq i (1- len))
 833                   (if (>= i len)
 834                       (setq i 0)))
 835                 (if (= i (1- len))
 836                     (setq prompt "Last one! ")
 837                   (if (= i 0)
 838                       (setq prompt "First one! "))))
 839             ;; if we skip several item, when arrive the first or last
 840             ;; item, we will stop at the one. But if we already at last
 841             ;; item, then keep going
 842             (if (< next 0)
 843                 (if (= i 0)
 844                     (setq i (mod next len))
 845                   (setq i 0
 846                         prompt "First one!"))
 847               (if (> next len)
 848                   (if (= i (1- len))
 849                       (setq i (mod next len))
 850                     (setq i (1- len)
 851                           prompt "Last one!")))))
 852           (setcar sepia-found i)
 853           (setq next (nth i list))
 854           (let ((file (car next))
 855                 (line (cadr next))
 856                 (short (nth 2 next))
 857                 (mod (nth 3 next)))
 858         (unless file
 859           (setq file (and mod (sepia-find-module-file mod)))
 860           (if file
 861                   (setcar next file)
 862                 (error "No file for %s." (car next))))
 863             (message "%s at %s:%s. %s" short file line prompt)
 864         (when (file-exists-p file)
 865           (find-file (or file (sepia-find-module-file mod)))
 866           (when sepia-found-refiner
 867             (funcall sepia-found-refiner line short))
 868           (beginning-of-line)
 869               (recenter)))))
 870       (message "No more definitions.")))
 871
 872 (defun sepia-previous (&optional arg)
 873   (interactive "p")
 874   (or arg (setq arg 1))
 875   (sepia-next (- arg)))
 876
 877 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 878 ;; Completion
 879
 880 (defun sepia-ident-before-point ()
 881   "Find the Perl identifier at or preceding point."
 882   (save-excursion
 883     (let* ((end (point))
 884            (beg (progn
 885                   (skip-chars-backward "a-zA-Z0-9_:")
 886                   (point)))
 887            (sigil (if (= beg (point-min))
 888                       nil
 889                       (char-before (point)))))
 890       (list (when (member sigil '(?$ ?@ ?% ?* ?&)) sigil)
 891             (buffer-substring-no-properties beg end)))))
 892
 893 (defun sepia-simple-method-before-point ()
 894   "Find the \"simple\" method call before point.
 895
 896 Looks for a simple method called on a variable before point and
 897 returns the list (OBJECT METHOD).  For example, \"$x->blah\"
 898 returns '(\"$x\" \"blah\").  Only simple methods are recognized,
 899 because completing anything evaluates it, so completing complex
 900 expressions would lead to disaster."
 901   (when sepia-complete-methods
 902     (let ((end (point))
 903           (bound (max (- (point) 100) (point-min)))
 904           arrow beg)
 905       (save-excursion
 906         ;; XXX - can't do this because COMINT's syntax table is weird.
 907         ;; (skip-syntax-backward "_w")
 908         (skip-chars-backward "a-zA-Z0-9_")
 909         (when (looking-back "->\\s *" bound)
 910           (setq arrow (search-backward "->" bound))
 911           (skip-chars-backward "a-zA-Z0-9_:")
 912           (cond
 913             ;; $x->method
 914             ((char-equal (char-before (point)) ?$)
 915              (setq beg (1- (point))))
 916             ;; X::Class->method
 917             ((multiple-value-bind (type obj) (sepia-ident-at-point)
 918                (and (not type)
 919                     (sepia-looks-like-module obj)))
 920              (setq beg (point))))
 921           (when beg
 922             (list (buffer-substring-no-properties beg arrow)
 923                   (buffer-substring-no-properties (+ 2 arrow) end)
 924                   (buffer-substring-no-properties beg end))))))))
 925
 926 (defun sepia-ident-at-point ()
 927   "Find the Perl identifier at point."
 928   (save-excursion
 929     (when (looking-at "[%$@*&]")
 930       (forward-char 1))
 931     (let* ((beg (progn
 932                  (when (re-search-backward "[^A-Za-z_0-9:]" nil 'mu)
 933                    (forward-char 1))
 934                  (point)))
 935           (sigil (if (= beg (point-min))
 936                      nil
 937                      (char-before (point))))
 938           (end (progn
 939                  (when (re-search-forward "[^A-Za-z_0-9:]" nil 'mu)
 940                    (forward-char -1))
 941                  (point))))
 942       (list (when (member sigil '(?$ ?@ ?% ?* ?&)) sigil)
 943             (buffer-substring-no-properties beg end)))))
 944
 945 (defun sepia-function-at-point ()
 946   "Find the Perl function called at point."
 947   (condition-case nil
 948       (save-excursion
 949         (let ((pt (point))
 950               bof)
 951           (sepia-beginning-of-defun)
 952           (setq bof (point))
 953           (goto-char pt)
 954           (sepia-end-of-defun)
 955           (when (and (>= pt bof) (< pt (point)))
 956             (goto-char bof)
 957             (looking-at "\\s *sub\\s +")
 958             (forward-char (length (match-string 0)))
 959             (concat (or (sepia-buffer-package) "")
 960                     "::"
 961                     (cadr (sepia-ident-at-point))))))
 962     (error nil)))
 963
 964 (defun sepia-repl-complete ()
 965   "Try to complete the word at point in the REPL.
 966 Just like `sepia-complete-symbol', except that it also completes
 967 REPL shortcuts."
 968   (interactive)
 969   (error "TODO"))
 970
 971 (defvar sepia-shortcuts
 972   '("break" "cd" "debug" "define" "delete" "eval" "format" "help" "lsbreak"
 973     "methods" "package" "pwd" "quit" "reload" "shell" "size" "strict" "undef"
 974     "wantarray")
 975   "List of currently-defined REPL shortcuts.
 976
 977 XXX: this needs to be updated whenever you add one on the Perl side.")
 978
 979 (defun sepia-complete-symbol ()
 980   "Try to complete the word at point.
 981 The word may be either a global variable if it has a
 982 sigil (sorry, no lexicals), a module, or a function.  The
 983 function currently ignores module qualifiers, which may be
 984 annoying in larger programs.
 985
 986 The function is intended to be bound to \\M-TAB, like
 987 `lisp-complete-symbol'."
 988   (interactive)
 989   (let ((win (get-buffer-window "*Completions*" 0))
 990         len
 991         completions
 992         type
 993         meth)
 994     (if (and (eq last-command this-command)
 995              win (window-live-p win) (window-buffer win)
 996              (buffer-name (window-buffer win)))
 997
 998         ;; If this command was repeated, and
 999         ;; there's a fresh completion window with a live buffer,
1000         ;; and this command is repeated, scroll that window.
1001         (with-current-buffer (window-buffer win)
1002           (if (pos-visible-in-window-p (point-max) win)
1003               (set-window-start win (point-min))
1004             (save-selected-window
1005               (select-window win)
1006               (scroll-up))))
1007
1008       ;; Otherwise actually do completion:
1009       ;; 0 - try a shortcut
1010       (save-excursion
1011         (comint-bol)
1012         (when (looking-at ",\\([a-z]+\\)\\(?:\\s \\|$\\)")
1013           (let ((str (match-string 1)))
1014             (setq len (length str)
1015                   completions (all-completions str sepia-shortcuts)))))
1016       ;; 1 - Look for a method call:
1017       (unless completions
1018         (setq meth (sepia-simple-method-before-point))
1019         (when meth
1020           (setq len (length (caddr meth))
1021                 completions (xref-method-completions
1022                              (cons 'expr (format "'%s'" (car meth)))
1023                              (cadr meth)
1024                              "Sepia::repl_eval")
1025                 type (format "%s->" (car meth)))))
1026       (multiple-value-bind (typ name) (sepia-ident-before-point)
1027         (unless completions
1028           ;; 2 - look for a regular function/variable/whatever
1029           (setq type typ
1030                 len (+ (if type 1 0) (length name))
1031                 completions (xref-completions
1032                              name
1033                              (case type
1034                                (?$ "VARIABLE")
1035                                (?@ "ARRAY")
1036                                (?% "HASH")
1037                                (?& "CODE")
1038                                (?* "IO")
1039                                (t ""))
1040                              (and (eq major-mode 'sepia-mode)
1041                                   (sepia-function-at-point)))))
1042         ;; 3 - try a Perl built-in
1043         (when (and (not completions)
1044                    (or (not type) (eq type ?&)))
1045           (when (string-match ".*::([^:]+)$" name)
1046             (setq name (match-string 1 name)))
1047           (setq completions (all-completions name sepia-perl-builtins)))
1048         (case (length completions)
1049           (0 (message "No completions.") nil)
1050           (1 ;; XXX - skip sigil to match s-i-before-point
1051            (delete-region (- (point) len) (point))
1052            (insert (or type "") (car completions))
1053            ;; Hide stale completions buffer (stolen from lisp.el).
1054            (if win (with-selected-window win (bury-buffer))) t)
1055           (t (let ((old name)
1056                    (new (try-completion "" completions)))
1057                (if (<= (length new) (length old))
1058                    (with-output-to-temp-buffer "*Completions*"
1059                      (display-completion-list completions))
1060                  (let ((win (get-buffer-window "*Completions*" 0)))
1061                    (if win (with-selected-window win (bury-buffer))))
1062                  (delete-region (- (point) len) (point))
1063                  (insert (or type "") new))))))
1064       t)))
1065
1066 (defun sepia-indent-or-complete ()
1067 "Indent the current line or complete the symbol around point.
1068
1069 Specifically, try completion when indentation doesn't move point.
1070 This function is intended to be bound to TAB."
1071   (interactive)
1072   (let ((pos (point)))
1073     (let (beginning-of-defun-function
1074           end-of-defun-function)
1075       (cperl-indent-command))
1076     (when (and (= pos (point))
1077                (not (bolp))
1078                (or (eq last-command 'sepia-indent-or-complete)
1079                    (looking-at "\\_>")))
1080       (unless (and sepia-indent-expand-abbrev
1081                    (expand-abbrev))
1082         (sepia-complete-symbol)))))
1083
1084 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1085 ;;; scratchpad code
1086
1087 (defvar sepia-mode-map
1088   (let ((map (copy-keymap sepia-shared-map)))
1089     (set-keymap-parent map cperl-mode-map)
1090     (define-key map "\C-c\C-h" nil)
1091     map)
1092  "Keymap for Sepia mode.")
1093
1094 (defvar sepia-mode-abbrev-table nil
1095 "Abbrevs for Sepia mode.")
1096
1097 ;;;###autoload
1098 (define-derived-mode sepia-mode cperl-mode "Sepia"
1099   "Major mode for Perl editing, derived from cperl mode.
1100 \\{sepia-mode-map}"
1101   :abbrev-table nil
1102   (sepia-init)
1103   (sepia-install-eldoc)
1104   (sepia-doc-update)
1105   (set (make-local-variable 'beginning-of-defun-function)
1106        'sepia-beginning-of-defun)
1107   (set (make-local-variable 'end-of-defun-function)
1108        'sepia-end-of-defun))
1109
1110 (defun sepia-init ()
1111   "Perform the initialization necessary to start Sepia."
1112     ;; Load perl defs:
1113   ;; Create glue wrappers for Module::Info funcs.
1114   (unless (fboundp 'xref-completions)
1115     (dolist (x '((name "Find module name.\n\nDoes not require loading.")
1116                  (version "Find module version.\n\nDoes not require loading.")
1117                  (inc-dir "Find directory in which this module was found.\n\nDoes not require loading.")
1118                  (file "Absolute path of file defining this module.\n\nDoes not require loading.")
1119                  (is-core "Guess whether or not a module is part of the core distribution.
1120 Does not require loading.")
1121                  (modules-used "List modules used by this module.\n\nRequires loading." list-context)
1122                  (packages-inside "List sub-packages in this module.\n\nRequires loading." list-context)
1123                  (superclasses "List module's superclasses.\n\nRequires loading." list-context)))
1124       (apply #'define-modinfo-function x))
1125     ;; Create low-level wrappers for Sepia
1126     (dolist (x '((completions "Find completions in the symbol table.")
1127                  (method-completions "Complete on an object's methods.")
1128                  (location "Find an identifier's location.")
1129                  (mod-subs "Find all subs defined in a package.")
1130                  (mod-decls "Generate declarations for subs in a package.")
1131                  (mod-file "Find the file defining a package.")
1132                  (apropos "Find subnames matching RE.")
1133                  (lexicals "Find lexicals for a sub.")
1134                  ))
1135       (apply #'define-xref-function "Sepia" x))
1136
1137     (dolist (x '((rebuild "Build Xref database for current Perl process.")
1138                  (redefined "Rebuild Xref information for a given sub.")
1139
1140                  (callers "Find all callers of a function.")
1141                  (callees "Find all functions called by a function.")
1142
1143                  (var-apropos "Find varnames matching RE.")
1144                  (mod-apropos "Find modules matching RE.")
1145                  (file-apropos "Find files matching RE.")
1146
1147                  (var-defs "Find all definitions of a variable.")
1148                  (var-assigns "Find all assignments to a variable.")
1149                  (var-uses "Find all uses of a variable.")
1150
1151                  (mod-redefined "Rebuild Xref information for a given package.")
1152                  (guess-module-file "Guess file corresponding to module.")
1153                  (file-modules "List the modules defined in a file.")))
1154       (apply #'define-xref-function "Sepia::Xref" x))
1155     ;; Initialize built hash
1156     (sepia-init-perl-builtins)))
1157
1158 (defvar sepia-scratchpad-mode-map
1159   (let ((map (make-sparse-keymap)))
1160     (set-keymap-parent map sepia-mode-map)
1161     (define-key map "\C-j" 'sepia-scratch-send-line)
1162     map))
1163
1164 ;;;###autoload
1165 (define-derived-mode sepia-scratchpad-mode sepia-mode "Sepia-Scratch"
1166   "Major mode for the Perl scratchpad, derived from Sepia mode."
1167   (sepia-init))
1168
1169 ;;;###autoload
1170 (defun sepia-scratch ()
1171   "Switch to the sepia scratchpad."
1172   (interactive)
1173   (pop-to-buffer
1174    (or (get-buffer "*sepia-scratch*")
1175        (with-current-buffer (get-buffer-create "*sepia-scratch*")
1176          (sepia-scratchpad-mode)
1177          (current-buffer)))))
1178
1179 (defun sepia-scratch-send-line (&optional scalarp)
1180   "Send the current line to perl, and display the result."
1181   (interactive "P")
1182   (insert "\n"
1183    (format "%S" (sepia-eval-raw (concat "scalar do{"
1184                        (buffer-substring (sepia-bol-from (point))
1185                                          (sepia-eol-from (point)))
1186                        "}")))
1187    "\n"))
1188
1189 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1190 ;; Miscellany
1191
1192 (defun sepia-string-count-matches (reg str)
1193   (let ((n 0)
1194         (pos -1))
1195     (while (setq pos (string-match reg str (1+ pos)))
1196       (incf n))
1197     n))
1198
1199 (defun sepia-perlize-region-internal (pre post beg end replace-p)
1200   "Pass buffer text from BEG to END through a Perl command."
1201   (let* ((exp (concat pre "<<'SEPIA_END_REGION';\n"
1202                       (buffer-substring-no-properties beg end)
1203                       (if (= (char-before end) ?\n) "" "\n")
1204                       "SEPIA_END_REGION\n" post))
1205          (new-str (car (sepia-eval-raw exp))))
1206     (if replace-p
1207         (progn (delete-region beg end)
1208                (goto-char beg)
1209                (insert new-str))
1210         (if (> (sepia-string-count-matches "\n" new-str) 2)
1211             (with-current-buffer (get-buffer-create "*sepia-filter*")
1212               (let ((inhibit-read-only t))
1213                 (erase-buffer)
1214                 (insert new-str)
1215                 (goto-char (point-min))
1216                 (pop-to-buffer (current-buffer))))
1217             (message "%s" new-str)))))
1218
1219 (defun sepia-eol-from (pt &optional n)
1220   (save-excursion
1221     (goto-char pt)
1222     (end-of-line n)
1223     (point)))
1224
1225 (defun sepia-bol-from (pt &optional n)
1226   (save-excursion
1227     (goto-char pt)
1228     (beginning-of-line n)
1229     (point)))
1230
1231 (defun sepia-perl-pe-region (expr beg end &optional replace-p)
1232   "Do the equivalent of perl -pe on region
1233
1234 \(i.e. evaluate an expression on each line of region).  With
1235 prefix arg, replace the region with the result."
1236   (interactive "MExpression: \nr\nP")
1237   (sepia-perlize-region-internal
1238    "do { my $ret=''; local $_; local $/ = \"\\n\"; my $region = "
1239    (concat "; for (split /(?<=\\n)/, $region, -1) { " expr
1240            "} continue { $ret.=$_}; $ret}")
1241    (sepia-bol-from beg) (sepia-eol-from end) replace-p))
1242
1243 (defun sepia-perl-ne-region (expr beg end &optional replace-p)
1244   "Do the moral equivalent of perl -ne on region
1245
1246 \(i.e. evaluate an expression on each line of region).  With
1247 prefix arg, replace the region with the result."
1248   (interactive "MExpression:\nr\nP")
1249   (sepia-perlize-region-internal
1250    "do { my $ret='';my $region = "
1251    (concat "; for (split /(?<=\\n)/, $region, -1) { $ret .= do { " expr
1252            ";} }; ''.$ret}")
1253    (sepia-bol-from beg) (sepia-eol-from end) replace-p))
1254
1255 (defun sepia-perlize-region (expr beg end &optional replace-p)
1256   "Evaluate a Perl expression on the region as a whole.
1257
1258 With prefix arg, replace the region with the result."
1259   (interactive "MExpression:\nr\nP")
1260   (sepia-perlize-region-internal
1261    "do { local $_ = " (concat "; do { " expr ";}; $_ }") beg end replace-p))
1262
1263 (defun sepia-core-version (module &optional message)
1264   "Report the first version of Perl shipping with MODULE."
1265   (interactive (list (sepia-interactive-arg 'module) t))
1266   (let* ((version
1267           (sepia-eval
1268            (format "eval { Sepia::core_version('%s') }" module)
1269            'scalar-context))
1270          (res (if version
1271                   (format "%s was first released in %s." module version)
1272                   (format "%s is not in core." module))))
1273     (when message (message "%s" res))
1274     res))
1275
1276 (defun sepia-guess-package (sub &optional file)
1277   "Guess which package SUB is defined in."
1278   (let ((defs (xref-location (xref-apropos sub))))
1279     (or (and (= (length defs) 1)
1280              (or (not file) (equal (caar defs) file))
1281              (fourth (car defs)))
1282         (and file
1283              (fourth (find-if (lambda (x) (equal (car x) file)) defs)))
1284         ;; (car (xref-file-modules file))
1285         (sepia-buffer-package))))
1286
1287 ;;;###autoload
1288 (defun sepia-eval-defun ()
1289   "Re-evaluate the current function and rebuild its Xrefs."
1290   (interactive)
1291   (let (pt end beg sub res
1292            sepia-eval-package
1293            sepia-eval-file
1294            sepia-eval-line)
1295     (save-excursion
1296       (setq pt (point)
1297             end (progn (end-of-defun) (point))
1298             beg (progn (beginning-of-defun) (point)))
1299       (goto-char beg)
1300       (when (looking-at "^sub\\s +\\(.+\\_>\\)")
1301         (setq sub (match-string 1))
1302         (let ((body (buffer-substring-no-properties beg end)))
1303
1304           (setq sepia-eval-package (sepia-guess-package sub (buffer-file-name))
1305                 sepia-eval-file (buffer-file-name)
1306                 sepia-eval-line (line-number-at-pos beg)
1307                 res
1308                 (sepia-eval-raw
1309                  (if sepia-eval-defun-include-decls
1310                      (concat
1311                       (apply #'concat (xref-mod-decls sepia-eval-package))
1312                       body)
1313                      body))))))
1314     (if (cdr res)
1315         (progn
1316           (when (string-match " line \\([0-9]+\\), near \"\\([^\"]*\\)\""
1317                               (cdr res))
1318             (goto-char beg)
1319             (beginning-of-line (parse-integer (match-string 1 (cdr res))))
1320             (search-forward (match-string 2 (cdr res))
1321                             (sepia-eol-from (point)) t))
1322           (message "Error: %s" (cdr res)))
1323         (xref-redefined sub sepia-eval-package)
1324         (message "Defined %s" sub))))
1325
1326 ;;;###autoload
1327 (defun sepia-eval-expression (expr &optional list-p message-p)
1328   "Evaluate EXPR in scalar context."
1329   (interactive (list (read-string "Expression: ") current-prefix-arg t))
1330   (let ((res (sepia-eval expr (if list-p 'list-context 'scalar-context))))
1331     (when message-p (message "%s" res))
1332     res))
1333
1334 (defun sepia-extract-def (file line obj)
1335   (with-current-buffer (find-file-noselect (expand-file-name file))
1336     (save-excursion
1337       (funcall (sepia-refiner 'function) line obj)
1338       (beginning-of-line)
1339       (when (looking-at (concat "^\\s *sub\\_>.*\\_<" obj "\\_>"))
1340         (buffer-substring (point)
1341                           (progn (end-of-defun) (point)))))))
1342
1343 (defun sepia-eval-no-run (string)
1344   (let ((res (sepia-eval-raw
1345               (concat "eval q#{ BEGIN { use B; B::minus_c(); $^C=1; } do { "
1346                       string
1347                       " };BEGIN { die \"ok\\n\" }#, $@"))))
1348     (if (string-match "^ok\n" (car res))
1349         nil
1350         (car res))))
1351
1352 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1353 ;; REPL
1354
1355 (defvar sepia-eval-file nil
1356   "File in which `sepia-eval' evaluates perl expressions.")
1357 (defvar sepia-eval-line nil
1358   "Line at which `sepia-eval' evaluates perl expressions.")
1359
1360 (defun sepia-set-cwd (dir)
1361   "Set the inferior Perl process's working directory to DIR.
1362
1363 When called interactively, the current buffer's
1364 `default-directory' is used."
1365   (interactive (list (expand-file-name default-directory)))
1366   (sepia-call "Cwd::chdir" dir))
1367
1368 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1369 ;; Doc-scanning
1370
1371 (defvar sepia-doc-map (make-hash-table :test #'equal))
1372 (defvar sepia-var-doc-map (make-hash-table :test #'equal))
1373 (defvar sepia-module-doc-map (make-hash-table :test #'equal))
1374
1375 (defun sepia-doc-scan-buffer ()
1376   (save-excursion
1377     (goto-char (point-min))
1378     (loop
1379        while (re-search-forward
1380                  "^=\\(item\\|head[2-9]\\)\\s +\\([%$&@A-Za-z_].*\\)" nil t)
1381        if
1382          (ignore-errors
1383            (let ((short (match-string 2)) longdoc)
1384               (setq short
1385                     (let ((case-fold-search nil))
1386                       (replace-regexp-in-string
1387                        "E<lt>" "<"
1388                        (replace-regexp-in-string
1389                         "E<gt>" ">"
1390                         (replace-regexp-in-string
1391                          "[A-DF-Z]<\\([^<>]+\\)>" "\\1" short)))))
1392               (while (string-match "^\\s *[A-Z]<\\(.*\\)>\\s *$" short)
1393                 (setq short (match-string 1 short)))
1394               (setq longdoc
1395                     (let ((beg (progn (forward-line 2) (point)))
1396                           (end (1- (re-search-forward "^=" nil t))))
1397                       (forward-line -1)
1398                       (goto-char beg)
1399                       (if (re-search-forward "^\\(.+\\)$" end t)
1400                           (concat short ": "
1401                                   (substring-no-properties
1402                                    (match-string 1)
1403                                    0 (position ?. (match-string 1))))
1404                           short)))
1405               (cond
1406                 ;; e.g. "$x -- this is x"
1407                 ((string-match "^[%$@]\\([A-Za-z0-9_:]+\\)\\s *--\\s *\\(.*\\)"
1408                                short)
1409                  (list 'variable (match-string-no-properties 1 short)
1410                        (or (and (equal short (match-string 1 short)) longdoc)
1411                            short)))
1412                 ;; e.g. "C<foo(BLAH)>" or "$x = $y->foo()"
1413                 ((string-match "\\([A-Za-z0-9_:]+\\)\\s *\\(\\$\\|(\\)" short)
1414                  (list 'function (match-string-no-properties 1 short)
1415                        (or (and (equal short (match-string 1 short)) longdoc)
1416                            short)))
1417                 ;; e.g. "$x this is x" (note: this has to come last)
1418                 ((string-match "^[%$@]\\([^( ]+\\)" short)
1419                  (list 'variable (match-string-no-properties 1 short) longdoc)))))
1420        collect it)))
1421
1422 (defun sepia-buffer-package ()
1423   (save-excursion
1424     (or (and (re-search-backward "^\\s *package\\s +\\([^ ;]+\\)\\s *;" nil t)
1425              (match-string-no-properties 1))
1426         "main")))
1427
1428 (defun sepia-doc-update ()
1429   "Update documentation for a file.
1430
1431 This documentation, taken from \"=item\" entries in the POD, is
1432 used for eldoc feedback."
1433   (interactive)
1434   (let ((pack (ifa (sepia-buffer-package) (concat it "::") "")))
1435     (dolist (x (sepia-doc-scan-buffer))
1436       (let ((map (ecase (car x)
1437                    (function sepia-doc-map)
1438                    (variable sepia-var-doc-map))))
1439         (puthash (second x) (third x) map)
1440         (puthash (concat pack (second x)) (third x) map)))))
1441
1442 (defun sepia-looks-like-module (obj)
1443   (let (case-fold-search)
1444     (or (string-match "^\\([A-Z][A-Za-z0-9]+::\\)*[A-Z]+[A-Za-z0-9]+\\sw*$" obj)
1445         (string-match
1446          (eval-when-compile (regexp-opt '("strict" "vars" "warnings" "lib")))
1447          obj))))
1448
1449 (defun sepia-symbol-info (&optional obj type)
1450   "Eldoc function for Sepia-mode.
1451
1452 Looks in `sepia-doc-map' and `sepia-var-doc-map', then tries
1453 calling `cperl-describe-perl-symbol'."
1454   (unless obj
1455     (multiple-value-bind (ty ob) (sepia-ident-at-point)
1456       (setq obj (if (consp ob) (car ob) ob)
1457             type ty)))
1458   (if obj
1459       (or (gethash obj (ecase (or type ?&)
1460                          (?& sepia-doc-map)
1461                          ((?$ ?@ ?%) sepia-var-doc-map)
1462                          (nil sepia-module-doc-map)
1463                          (?* sepia-module-doc-map)
1464                          (t (error "sepia-symbol-info: %s" type))))
1465           ;; Loathe cperl a bit.
1466           (flet ((message (&rest blah) (apply #'format blah)))
1467             (let* (case-fold-search
1468                    (cperl-message-on-help-error nil)
1469                    (hlp (car (save-excursion (cperl-describe-perl-symbol obj)))))
1470               (if hlp
1471                   (progn
1472                     ;; cperl's docstrings are too long.
1473                     (setq hlp (replace-regexp-in-string "\\s \\{2,\\}" "  " hlp))
1474                     (if (> (length hlp) 75)
1475                         (concat (substring hlp 0 72) "...")
1476                         hlp))
1477                   ;; Try to see if it's a module
1478                   (if (and
1479                        (let ((bol (save-excursion (beginning-of-line)
1480                                                   (point))))
1481                          (looking-back " *\\(?:use\\|require\\|package\\) +[^ ]+" bol))
1482                        (sepia-looks-like-module obj))
1483                       (sepia-core-version obj)
1484                       ""))))
1485       "")))
1486
1487 (defun sepia-install-eldoc ()
1488   "Install Sepia hooks for eldoc support."
1489   (interactive)
1490   (require 'eldoc)
1491   (set-variable 'eldoc-documentation-function 'sepia-symbol-info t)
1492   (if cperl-lazy-installed (cperl-lazy-unstall))
1493   (eldoc-mode 1)
1494   (set-variable 'eldoc-idle-delay 1.0 t))
1495
1496 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1497 ;; Error jump:
1498
1499 (defun sepia-extract-next-warning (pos &optional end)
1500   (catch 'foo
1501     (while (re-search-forward "^\\(.+\\) at \\(.+?\\) line \\([0-9]+\\)"
1502                               end t)
1503       (unless (string= "(eval " (substring (match-string 2) 0 6))
1504         (throw 'foo (list (match-string 2)
1505                           (parse-integer (match-string 3))
1506                           (match-string 1)))))))
1507
1508 (defun sepia-goto-error-at (pos)
1509   "Visit the source of the error on line at point."
1510   (interactive "d")
1511   (ifa (sepia-extract-next-warning (sepia-bol-from pos) (sepia-eol-from pos))
1512        (destructuring-bind (file line msg) it
1513          (find-file file)
1514          (goto-line line)
1515          (message "%s" msg))
1516        (error "No error to find.")))
1517
1518 (defun sepia-display-errors (beg end)
1519   "Display source causing errors in current buffer from BEG to END."
1520   (interactive "r")
1521   (goto-char beg)
1522   (let ((msgs nil))
1523     (loop for w = (sepia-extract-next-warning (sepia-bol-from (point)) end)
1524        while w
1525        do (destructuring-bind (file line msg) w
1526             (push (format "%s:%d:%s\n" (abbreviate-file-name file) line msg)
1527                   msgs)))
1528     (erase-buffer)
1529     (goto-char (point-min))
1530     (mapcar #'insert (nreverse msgs))
1531     (goto-char (point-min))
1532     (grep-mode)))
1533
1534 (defun sepia-lisp-to-perl (thing)
1535   "Convert elisp data structure to Perl."
1536   (cond
1537     ((null thing) "undef")
1538     ((symbolp thing)
1539      (let ((pname (substitute ?_ ?- (symbol-name thing)))
1540            (type (string-to-char (symbol-name thing))))
1541        (if (member type '(?% ?$ ?@ ?*))
1542            pname
1543            (concat "\\*" pname))))
1544     ((stringp thing) (format "%S" (substring-no-properties thing 0)))
1545     ((integerp thing) (format "%d" thing))
1546     ((numberp thing) (format "%g" thing))
1547     ;; Perl expression
1548     ((and (consp thing) (eq (car thing) 'expr))
1549      (cdr thing))        ; XXX -- need quoting??
1550     ((and (consp thing) (not (consp (cdr thing))))
1551      (concat (sepia-lisp-to-perl (car thing)) " => "
1552              (sepia-lisp-to-perl (cdr thing))))
1553     ;; list
1554     ((or (not (consp (car thing)))
1555          (listp (cdar thing)))
1556      (concat "[" (mapconcat #'sepia-lisp-to-perl thing ", ") "]"))
1557     ;; hash table
1558     (t
1559      (concat "{" (mapconcat #'sepia-lisp-to-perl thing ", ") "}"))))
1560
1561 (defun sepia-init-perl-builtins ()
1562   (setq sepia-perl-builtins (make-hash-table))
1563   (dolist (s '("abs"
1564 "accept"
1565 "alarm"
1566 "atan2"
1567 "bind"
1568 "binmode"
1569 "bless"
1570 "caller"
1571 "chdir"
1572 "chmod"
1573 "chomp"
1574 "chop"
1575 "chown"
1576 "chr"
1577 "chroot"
1578 "close"
1579 "closedir"
1580 "connect"
1581 "continue"
1582 "cos"
1583 "crypt"
1584 "dbmclose"
1585 "dbmopen"
1586 "defined"
1587 "delete"
1588 "die"
1589 "dump"
1590 "each"
1591 "endgrent"
1592 "endhostent"
1593 "endnetent"
1594 "endprotoent"
1595 "endpwent"
1596 "endservent"
1597 "eof"
1598 "eval"
1599 "exec"
1600 "exists"
1601 "exit"
1602 "exp"
1603 "fcntl"
1604 "fileno"
1605 "flock"
1606 "fork"
1607 "format"
1608 "formline"
1609 "getc"
1610 "getgrent"
1611 "getgrgid"
1612 "getgrnam"
1613 "gethostbyaddr"
1614 "gethostbyname"
1615 "gethostent"
1616 "getlogin"
1617 "getnetbyaddr"
1618 "getnetbyname"
1619 "getnetent"
1620 "getpeername"
1621 "getpgrp"
1622 "getppid"
1623 "getpriority"
1624 "getprotobyname"
1625 "getprotobynumber"
1626 "getprotoent"
1627 "getpwent"
1628 "getpwnam"
1629 "getpwuid"
1630 "getservbyname"
1631 "getservbyport"
1632 "getservent"
1633 "getsockname"
1634 "getsockopt"
1635 "glob"
1636 "gmtime"
1637 "goto"
1638 "grep"
1639 "hex"
1640 "import"
1641 "index"
1642 "int"
1643 "ioctl"
1644 "join"
1645 "keys"
1646 "kill"
1647 "last"
1648 "lc"
1649 "lcfirst"
1650 "length"
1651 "link"
1652 "listen"
1653 "local"
1654 "localtime"
1655 "log"
1656 "lstat"
1657 "map"
1658 "mkdir"
1659 "msgctl"
1660 "msgget"
1661 "msgrcv"
1662 "msgsnd"
1663 "next"
1664 "oct"
1665 "open"
1666 "opendir"
1667 "ord"
1668 "pack"
1669 "package"
1670 "pipe"
1671 "pop"
1672 "pos"
1673 "print"
1674 "printf"
1675 "prototype"
1676 "push"
1677 "quotemeta"
1678 "rand"
1679 "read"
1680 "readdir"
1681 "readline"
1682 "readlink"
1683 "readpipe"
1684 "recv"
1685 "redo"
1686 "ref"
1687 "rename"
1688 "require"
1689 "reset"
1690 "return"
1691 "reverse"
1692 "rewinddir"
1693 "rindex"
1694 "rmdir"
1695 "scalar"
1696 "seek"
1697 "seekdir"
1698 "select"
1699 "semctl"
1700 "semget"
1701 "semop"
1702 "send"
1703 "setgrent"
1704 "sethostent"
1705 "setnetent"
1706 "setpgrp"
1707 "setpriority"
1708 "setprotoent"
1709 "setpwent"
1710 "setservent"
1711 "setsockopt"
1712 "shift"
1713 "shmctl"
1714 "shmget"
1715 "shmread"
1716 "shmwrite"
1717 "shutdown"
1718 "sin"
1719 "sleep"
1720 "socket"
1721 "socketpair"
1722 "sort"
1723 "splice"
1724 "split"
1725 "sprintf"
1726 "sqrt"
1727 "srand"
1728 "stat"
1729 "study"
1730 "sub"
1731 "sub*"
1732 "substr"
1733 "symlink"
1734 "syscall"
1735 "sysopen"
1736 "sysread"
1737 "sysseek"
1738 "system"
1739 "syswrite"
1740 "tell"
1741 "telldir"
1742 "tie"
1743 "tied"
1744 "time"
1745 "times"
1746 "truncate"
1747 "uc"
1748 "ucfirst"
1749 "umask"
1750 "undef"
1751 "unlink"
1752 "unpack"
1753 "unshift"
1754 "untie"
1755 "utime"
1756 "values"
1757 "vec"
1758 "wait"
1759 "waitpid"
1760 "wantarray"
1761 "warn"
1762 "write"
1763 ))
1764         (puthash s t sepia-perl-builtins)))
1765
1766 (provide 'sepia)
1767 ;;; sepia.el ends here