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 Sean O'Rourke.  All rights reserved, some wrongs
   5 ;; reversed.  This code is distributed under the same terms as Perl
   6 ;; itself.
   7
   8 ;;; Commentary:
   9
  10 ;; See the README file that comes with the distribution.
  11
  12 ;;; Code:
  13
  14 (require 'perl)
  15 (require 'epl)
  16 (require 'generic-repl)
  17 (require 'cperl-mode)
  18
  19 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20 ;;; Xrefs -- use Perl to find definitions and uses.
  21
  22 (defvar sepia-use-completion t
  23   "* Use completion based on Xref database.  Turning this off may
  24 speed up some operations, if you don't mind losing completion.")
  25
  26 (defvar sepia-eval-defun-include-decls t
  27   "* Generate and use a declaration list for ``sepia-eval-defun''.
  28 Without this, code often will not parse; with it, evaluation may
  29 be a bit less responsive.  Note that since this only includes
  30 subs from the evaluation package, it may not always work.")
  31
  32 (defvar sepia-prefix-key "\M-."
  33   "* Prefix for functions in ``sepia-keymap''.")
  34
  35 (defvar sepia-initializer
  36 "
  37 BEGIN { push @INC, \"$ENV{HOME}/src/perl\" };
  38 use Emacs::Lisp;
  39 use Devel::Xref;
  40 use Module::Info;
  41 use Data::Dumper;
  42
  43 sub _module_info($)
  44 {
  45     my ($m, $func) = @_;
  46     my $info;
  47     if (-f $m) {
  48         $info = Module::Info->new_from_file($m);
  49     } else {
  50         (my $file = $m) =~ s|::|/|g;
  51         $file .= '.pm';
  52         if (exists $INC{$file}) {
  53             $info = Module::Info->new_from_loaded($m);
  54         } else {
  55             $info = Module::Info->new_from_module($m);
  56         }
  57     }
  58     if ($info) {
  59         return $info->$func;
  60     }
  61 }
  62
  63 1;
  64 ")
  65
  66 (defvar sepia-keymap
  67   (let ((km (make-sparse-keymap)))
  68     (dolist (kv '(("c" . sepia-callers)
  69                   ("C" . sepia-callees)
  70                   ("v" . sepia-var-uses)
  71                   ("V" . sepia-var-defs)
  72 ;;                ("V" . sepia-var-assigns)
  73 ;;                ("\M-." . sepia-dwim)
  74                   ("\M-." . sepia-location)
  75                   ("d" . sepia-w3m-perldoc-this)
  76                   ("f" . sepia-defs)
  77                   ("r" . sepia-rebuild)
  78                   ("m" . sepia-module-find)
  79                   ("n" . sepia-next)))
  80       (define-key km (car kv) (cdr kv)))
  81     km)
  82   "Keymap for Sepia functions.  This is just an example of how you
  83 might want to bind your keys, which works best when bound to
  84 `\\M-.'.")
  85
  86 (defun sepia-install-keys (&optional map)
  87 "Install Sepia bindings in the current local keymap."
  88   (interactive)
  89   (let ((map (or map (current-local-map))))
  90     (define-key map sepia-prefix-key sepia-keymap)
  91     (define-key map "\M-," 'sepia-next)
  92     (define-key map "\C-\M-x" 'sepia-eval-defun)
  93     (define-key map "\C-c\C-l" 'sepia-eval-buffer)
  94     (define-key map "\C-c\C-d" 'sepia-w3m-view-pod)))
  95
  96 (defun perl-name (sym)
  97   (substitute ?_ ?- (symbol-name sym)))
  98
  99 ;;;###autoload
 100 (defun sepia-init ()
 101 "Perform the initialization necessary to start Sepia, a set of
 102 tools for developing Perl in Emacs.
 103
 104 The following keys are bound to the prefix
 105 ``sepia-prefix-key'' (`\\M-.' by default), which can be changed
 106 by setting ``sepia-prefix'' before calling ``sepia-init'':
 107
 108 \\{sepia-keymap}
 109
 110 In addition to these keys, Sepia defines the following keys,
 111 which may conflict with keys in your setup, but which are
 112 intended to shadow similar functionality in elisp-mode:
 113
 114 `\\C-c\\C-d'        ``sepia-w3m-view-pod''
 115 `\\C-c\\C-l'        ``sepia-eval-buffer''
 116 `\\C-\\M-x'         ``sepia-eval-defun''
 117 `\\M-,'             ``sepia-next'' (shadows ``tags-loop-continue'')
 118 "
 119   (interactive)
 120
 121   (ignore-errors
 122     (kill-process "perl")
 123     (setq perl-interpreter nil))
 124   (epl-init)
 125     ;; Load perl defs:
 126   (perl-eval sepia-initializer 'void-context)
 127
 128   ;; Create glue wrappers for Module::Info funcs.
 129   (dolist (x '((name . "Find module name.  Does not require loading.")
 130                (version . "Find module version.  Does not require loading.")
 131                (inc-dir .
 132 "Find directory in which this module was found.  Does not require loading.")
 133                (file .
 134 "Absolute path of file defining this module.  Does not require loading.")
 135                (is-core .
 136 "Guess whether or not a module is part of the core distribution.
 137 Does not require loading.")
 138                (modules-used .
 139 "List modules used by this module.  Requires loading.")
 140                (packages-inside .
 141 "List sub-packages in this module.  Requires loading.")
 142                (superclasses .
 143 "List module's superclasses.  Requires loading.")))
 144     (define-modinfo-function (car x) (cdr x)))
 145
 146   ;; Create low-level wrappers for Devel::Xref
 147   (dolist (x '((rebuild . "Build Xref database for current Perl process.")
 148                (redefined . "Rebuild Xref information for a given sub.")
 149                (completions . "Find completions in the symbol table.")
 150                (location . "Find an identifier's location.")
 151
 152                (defs . "Find all definitions of a function.")
 153                (callers . "Find all callers of a function.")
 154                (callees . "Find all functions called by a function.")
 155
 156                (apropos . "Find subnames matching RE.")
 157                (var-apropos . "Find varnames matching RE.")
 158                (mod-apropos . "Find modules matching RE.")
 159                (file-apropos . "Find files matching RE.")
 160
 161                (var-defs . "Find all definitions of a variable.")
 162                (var-assigns . "Find all assignments to a variable.")
 163                (var-uses . "Find all uses of a variable.")
 164
 165                (mod-redefined . "Rebuild Xref information for a given package.")
 166                (mod-subs . "Find all subs defined in a package.")
 167                (mod-files . "Find the file defining a package.")
 168                (mod-decls . "Generate declarations for subs in a package.")
 169                (guess-module-file . "Guess file corresponding to module.")
 170                (file-modules . "List the modules defined in a file.")))
 171     (define-xref-function (car x) (cdr x)))
 172   (add-hook 'cperl-mode-hook 'sepia-install-eldoc)
 173   (add-hook 'cperl-mode-hook 'sepia-doc-update)
 174   (add-hook 'sepia-repl-hook 'sepia-repl-init-syntax)
 175   (add-hook 'sepia-repl-hook 'sepia-install-eldoc)
 176   (if (boundp 'cperl-mode-map)
 177       (sepia-install-keys cperl-mode-map))
 178   (sepia-rebuild)
 179   (sepia-interact))
 180
 181 (defun define-xref-function (name doc)
 182   "Define a lisp mirror for a function from Devel::Xref."
 183   (let ((lisp-name (intern (format "xref-%s" name)))
 184         (pl-name (format "Devel::Xref::%s" (perl-name name))))
 185     (when (fboundp lisp-name) (fmakunbound lisp-name))
 186     (eval `(defun ,lisp-name (&rest args)
 187              ,doc
 188              (apply #'perl-call ,pl-name 'list-context args)))))
 189
 190 (defun define-modinfo-function (name &optional doc)
 191 "Define a lisp mirror for a function from Module::Info."
 192   (let ((name (intern (format "sepia-module-%s" name)))
 193         (pl-func (perl-name name))
 194         (full-doc (concat (or doc "") "
 195
 196 This function uses Module::Info, so it does not require that the
 197 module in question be loaded.")))
 198     (when (fboundp name) (fmakunbound name))
 199     (eval `(defun ,name (mod)
 200              ,full-doc
 201              (interactive (list (sepia-interactive-arg 'module)))
 202              (let ((res (perl-call "_module_info" 'scalar-context
 203                                    mod ,pl-func)))
 204                (if (interactive-p)
 205                    (message "%s" res)
 206                    res))))))
 207
 208 (defun sepia-thing-at-point (what)
 209   "Like ``thing-at-point'', but hacked to avoid REPL prompt."
 210   (let ((th (thing-at-point what)))
 211     (and th (not (string-match "[ >]$" th)) th)))
 212
 213 (defun sepia-interactive-arg (&optional type)
 214 "Default argument for most Sepia functions.  TYPE is a symbol --
 215 either 'file to look for a file, or anything else to use the
 216 symbol at point."
 217   (let* ((default (case type
 218                     (file (or (thing-at-point 'file) (buffer-file-name)))
 219                     (t (sepia-thing-at-point 'symbol))))
 220          (text (capitalize (symbol-name type)))
 221          (choices (lambda (str &rest blah)
 222                     (let ((str (concat "^" str)))
 223                       (case type
 224                         (variable (xref-var-apropos str))
 225                         (function (xref-apropos str))
 226                         (module (xref-mod-apropos str))
 227                         (t nil)))))
 228          (ret (if sepia-use-completion
 229                   (completing-read (format "%s [%s]: " text default)
 230                                    choices nil nil nil 'sepia-history
 231                                    default)
 232                   (read-string (format "%s [%s]: " text default)
 233                                nil 'sepia-history default))))
 234     (push ret sepia-history)
 235     ret))
 236
 237 (defun sepia-interactive-module ()
 238 "Guess which module we should look things up in.  Prompting for a
 239 module all the time is a PITA, but I don't think this (choosing
 240 the current file's module) is a good alternative, either.  Best
 241 would be to choose the module based on what we know about the
 242 symbol at point."
 243   (let ((xs (xref-file-modules (buffer-file-name))))
 244     (if (= (length xs) 1)
 245         (car xs)
 246         nil)))
 247
 248 (defun sepia-maybe-echo (result)
 249   (when (interactive-p)
 250     (message "%s" result))
 251   result)
 252
 253 (defun sepia-module-find (mod)
 254 "Find the file defining module MOD."
 255   (interactive (list (sepia-interactive-arg 'module)))
 256   (let ((fn (or (sepia-module-file mod)
 257                 (xref-guess-module-file mod))))
 258     (when fn
 259       (message "Module %s in %s." mod fn)
 260       (pop-to-buffer (find-file-noselect (expand-file-name fn))))))
 261
 262 (defmacro ifa (test then &rest else)
 263   `(let ((it ,test))
 264      (if it ,then ,@else)))
 265
 266 (defun sepia-show-locations (locs)
 267   (when locs
 268     (pop-to-buffer (get-buffer-create "*sepia-places*"))
 269     (erase-buffer)
 270     (dolist (loc (sort locs (lambda (a b)
 271                               (or (string< (car a) (car b))
 272                                   (and (string= (car a) (car b))
 273                                        (< (second a) (second b)))))))
 274       (destructuring-bind (file line name &rest blah) loc
 275         (let ((str (ifa (find-buffer-visiting file)
 276                         (with-current-buffer it
 277                           (ifa sepia-found-refiner
 278                                (funcall it line name)
 279                                (goto-line line))
 280                           (message "line for %s was %d, now %d" name line
 281                                    (line-number-at-pos))
 282                           (setq line (line-number-at-pos))
 283                           (concat "\n    "
 284                                   (buffer-substring (my-bol-from (point))
 285                                                     (my-eol-from (point)))))
 286                         "...")))
 287           (insert (format "%s:%d:%s\n" (abbreviate-file-name file) line str)))))
 288     (grep-mode)
 289     (goto-char (point-min))))
 290
 291 (defun sepia-filter-by-module (x)
 292   "Filter to limit hits by module only."
 293   (when (or (not module) (string= module (fourth x)))
 294     (list x)))
 295
 296 (defun sepia-filter-by-all (x)
 297   "Filter to limit hits by module and file."
 298   (when (and (or (not module) (string= module (fourth x)))
 299              (or (not file) (string= file (first x))))
 300     (list x)))
 301
 302 (defmacro define-sepia-query (name doc &optional gen test prompt)
 303   `(defun ,name (ident &optional module file line display-p)
 304      ,(concat doc "
 305
 306 With prefix arg, list occurences in a ``grep-mode'' buffer.
 307 Without, place the occurrences on ``sepia-found'', so that
 308 calling ``sepia-next'' will cycle through them.
 309
 310 Depending on the query, MODULE, FILE, and LINE may be used to
 311 narrow the results, as long as doing so leaves some matches.
 312 When called interactively, they are taken from the current
 313 buffer.
 314 ")
 315      (interactive (list (sepia-interactive-arg ,(or prompt ''function))
 316                         (sepia-interactive-module)
 317                         (buffer-file-name)
 318                         (line-number-at-pos (point))
 319                         current-prefix-arg
 320                         ))
 321      (let ((ret
 322             ,(if test
 323                  `(let ((tmp  (,gen ident module file line)))
 324                     (or (mapcan #',test tmp) tmp))
 325                  `(,gen ident module file line))))
 326        ;; Always clear out the last found ring, because it's confusing
 327        ;; otherwise.
 328        (sepia-set-found nil ',(or prompt 'function))
 329        (if display-p
 330            (sepia-show-locations ret)
 331            (sepia-set-found ret ',(or prompt 'function))
 332            (sepia-next)))))
 333
 334 (defun sepia-location (name)
 335   (interactive (list (or (thing-at-point 'symbol)
 336                          (completing-read "Function: " 'xref-completions))))
 337   (let ((fl  (xref-location name)))
 338     (when fl
 339       (destructuring-bind (file line shortname) fl
 340         (if (string-match "^(eval " file)
 341             (error "Can't find definition of %s in %s." name file)
 342             (sepia-set-found (list fl))
 343             (sepia-next))))))
 344
 345 ;;;###autoload
 346 (defun sepia-dwim (&optional display-p)
 347     "Try to DWIM:
 348 * Find all definitions, if thing-at-point is a function
 349 * Find all uses, if thing-at-point is a variable
 350 * Find all definitions, if thing-at-point is a module
 351 * Prompt otherwise
 352 "
 353     (interactive "P")
 354     (multiple-value-bind (obj mod type) (sepia-ident-at-point)
 355       (if type
 356           (progn
 357             (sepia-set-found nil type)
 358             (let ((ret (ecase type
 359                          (function (xref-defs obj mod))
 360                          (variable (xref-var-uses obj mod))
 361                          (module `((,(car (xref-mod-files mod)) 1 nil nil))))))
 362               (if display-p
 363                   (sepia-show-locations ret)
 364                   (sepia-set-found ret type)
 365                   (sepia-next))))
 366           (call-interactively 'sepia-defs))))
 367
 368 (define-sepia-query sepia-defs
 369     "Find all definitions of sub."
 370   xref-defs)
 371
 372 (define-sepia-query sepia-uses
 373     "Find all uses of sub (i.e. positions within its callers)."
 374   xref-callers
 375   (lambda (x) (setf (third x) ident) (list x)))
 376
 377 (define-sepia-query sepia-callers
 378     "Find callers of FUNC."
 379   xref-callers)
 380
 381 (define-sepia-query sepia-callees
 382     "Find a sub's callees."
 383   xref-callees)
 384
 385 (define-sepia-query sepia-var-defs
 386     "Find a var's definitions."
 387   xref-var-defs
 388   (lambda (x) (setf (third x) ident) (list x))
 389   'variable)
 390
 391 (define-sepia-query sepia-var-uses
 392     "Find a var's uses."
 393   xref-var-uses
 394   (lambda (x) (setf (third x) ident) (list x))
 395   'variable)
 396
 397 (define-sepia-query sepia-var-assigns
 398     "Find/list assignments to a variable."
 399   xref-var-assigns
 400   (lambda (x) (setf (third x) ident) (list x))
 401   'variable)
 402
 403 (define-sepia-query sepia-module-describe
 404     "Find all subroutines in a package."
 405   xref-mod-subs
 406   nil
 407   'module)
 408
 409 (defalias 'sepia-package-defs 'sepia-module-describe)
 410
 411 (define-sepia-query sepia-apropos
 412     "Find/list subroutines matching regexp."
 413   xref-apropos
 414   xref-defs
 415   'function)
 416
 417 (define-sepia-query sepia-var-apropos
 418     "Find/list variables matching regexp."
 419   xref-var-apropos
 420   xref-var-defs
 421   'variable)
 422
 423 (defun sepia-rebuild ()
 424   "Rebuild the Xref database."
 425   (interactive)
 426   (xref-rebuild))
 427
 428 ;;;###autoload
 429 (defun sepia-load-file (file rebuild-p)
 430   "Reload a file, possibly rebuilding the Xref database.  When
 431 called interactively, reloads the current buffer's file, and
 432 rebuilds the database unless a prefix argument is given."
 433   (interactive (list (buffer-file-name) (not prefix-arg)))
 434   (perl-load-file file)
 435   (if rebuild-p
 436       (xref-rebuild)))
 437
 438 (defvar sepia-found)
 439 (defvar sepia-found-head)
 440 (defvar sepia-found-refiner)
 441 (defvar sepia-history nil)
 442
 443 (defun sepia-set-found (list &optional type)
 444   (setq list
 445         (remove-if (lambda (x)
 446                      (and (not (car x)) (string= (fourth x) "main")))
 447                    list))
 448   (setq sepia-found list
 449         sepia-found-head list)
 450   (setq sepia-found-refiner (sepia-refiner type))
 451   ;; (when (length list)
 452 ;;     (message "sepia: found %d %s%s." (length list)
 453 ;;             (or type "item")
 454 ;;             (if (= (length list) 1) "" "s")))
 455   )
 456
 457 (defun sepia-refiner (type)
 458   (case type
 459     (function
 460      (lambda (line ident)
 461       (let ((sub-re (concat "^\\s *sub\\s +.*" ident "\\>")))
 462         ;; Test this because sometimes we get lucky and get the line
 463         ;; just right, in which case beginning-of-defun goes to the
 464         ;; previous defun.
 465         (unless (looking-at sub-re)
 466           (or (and line
 467                    (progn
 468                      (goto-line line)
 469                      (beginning-of-defun)
 470                      (looking-at sub-re)))
 471               (progn (goto-char (point-min))
 472                      (re-search-forward sub-re nil t)))
 473           (beginning-of-line)))))
 474     ;; Old version -- this may actually work better if
 475     ;; beginning-of-defun goes flaky on us.
 476 ;;         (or (re-search-backward sub-re
 477 ;;                                 (my-bol-from (point) -20) t)
 478 ;;             (re-search-forward sub-re
 479 ;;                                (my-bol-from (point) 10) t))
 480 ;;         (beginning-of-line)
 481     (variable
 482      (lambda (line ident)
 483        (let ((var-re (concat "\\<" ident "\\>")))
 484          (cond
 485            (line (goto-line line)
 486                  (or (re-search-backward var-re (my-bol-from (point) -5) t)
 487                      (re-search-forward var-re (my-bol-from (point) 5) t)))
 488            (t (goto-char (point-min))
 489               (re-search-forward var-re nil t))))))
 490     (t (lambda (line ident) (and line (goto-line line))))))
 491
 492 (defun sepia-next ()
 493 "Go to the next thing (e.g. def, use) found by sepia."
 494   (interactive)
 495   (if sepia-found
 496       (destructuring-bind (file line short &optional mod &rest blah)
 497           (car sepia-found)
 498         (unless file
 499           (setq file (and mod (sepia-module-file mod)))
 500           (if file
 501               (setf (caar sepia-found) file)
 502               (error "No file for %s." (car sepia-found))))
 503         (message "%s at %s:%s" short file line)
 504         (when (file-exists-p file)
 505           (find-file (or file (car (xref-mod-files mod))))
 506           (when sepia-found-refiner
 507             (funcall sepia-found-refiner line short))
 508           (beginning-of-line)
 509           (recenter)
 510           (setq sepia-found (or (cdr sepia-found)
 511                                 (progn
 512                                   (message "sepia: no more defs.")
 513                                   sepia-found-head)))))
 514       (message "No more definitions.")))
 515
 516 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 517 ;; Completion
 518
 519 (defun sepia-ident-at-point ()
 520   "Find the perl identifier at point, returning
 521 \(values OBJECT MODULE TYPE RAW), where TYPE is either 'variable,
 522 'function, or 'module.  If TYPE is 'module, OBJ is the last
 523 component of the module name."
 524   (let ((cperl-under-as-char nil)
 525         (case-fold-search nil)
 526         var-p module-p modpart objpart)
 527     (condition-case c
 528         (destructuring-bind (sbeg . send) (bounds-of-thing-at-point 'symbol)
 529           (destructuring-bind (wbeg . wend) (or (bounds-of-thing-at-point 'word)
 530                                                 (cons (point) (point)))
 531             (if (member (char-before send) '(?> ?\ ))
 532                 (signal 'wrong-number-of-arguments 'sorta))
 533             (setq var-p
 534                   (or (member (char-before wbeg) '(?@ ?$ ?%))
 535                       (member (char-before sbeg) '(?@ ?$ ?%))))
 536             (setq module-p
 537                   (save-excursion (goto-char wbeg) (looking-at "[A-Z]")))
 538             (setq modpart
 539                   (if (= sbeg wbeg)
 540                       nil
 541                       (buffer-substring sbeg
 542                                         (if (= (char-before (1- wbeg)) ?\:)
 543                                             (- wbeg 2)
 544                                             (1- wbeg)))))
 545             (setq objpart (buffer-substring wbeg wend))
 546             (values (if module-p
 547                         (list objpart modpart (if var-p 'variable 'function))
 548                         objpart)
 549                     (if module-p
 550                         (buffer-substring sbeg send)
 551                         modpart)
 552                     (cond
 553                       (module-p 'module)
 554                       (var-p 'variable)
 555                       (t 'function))
 556                     (buffer-substring sbeg send))))
 557       (wrong-number-of-arguments (values nil nil nil)))))
 558
 559 (defun delete-thing-at-point (sym)
 560   (destructuring-bind (beg . end) (bounds-of-thing-at-point sym)
 561     (delete-region beg end)))
 562
 563 (defun sepia-complete-symbol ()
 564 "Try to complete the word at point:
 565     * as a global variable, if it has a sigil (sorry, no lexical
 566       var completion).
 567     * as a module, if its last namepart begins with an uppercase
 568       letter.
 569     * as a function, otherwise.
 570 The function currently ignores module qualifiers, which may be
 571 annoying in larger programs.
 572
 573 The function is intended to be bound to \\M-TAB, like
 574 ``lisp-complete-symbol''."
 575   (interactive)
 576   (let ((tap (or (thing-at-point 'symbol)
 577                  (and (eq last-command 'sepia-complete-symbol) ""))))
 578     (if tap
 579         (let ((completions (xref-completions tap)))
 580           (case (length completions)
 581             (0 (message "No completions for %s." tap))
 582             (1 (delete-thing-at-point 'symbol)
 583                (insert (car completions)))
 584             (t (delete-thing-at-point 'symbol)
 585                (insert (try-completion "" completions))
 586                (with-output-to-temp-buffer "*Completions*"
 587                  (display-completion-list completions)))))
 588         (message "sepia: empty -- hit tab again to complete."))))
 589
 590 (defun sepia-indent-or-complete ()
 591 "Indent the current line and, if indentation doesn't move point,
 592 complete the symbol around point.  This function is intended to
 593 be bound to TAB."
 594   (interactive)
 595   (let ((pos (point)))
 596     (cperl-indent-command)
 597     (when (and (= pos (point))
 598                (eq last-command 'sepia-indent-or-complete))
 599       (sepia-complete-symbol))))
 600
 601 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 602 ;;; scratchpad code
 603
 604 ;;;###autoload
 605 (defun sepia-scratchpad ()
 606 "Create a buffer to interact with a Perl interpreter.  The buffer
 607 is placed in cperl-mode; calling ``sepia-scratch-send-line'' will
 608 evaluate the current line and display the result."
 609   (interactive)
 610   (switch-to-buffer (get-buffer-create "*perl-interaction*"))
 611   (cperl-mode)
 612   (local-set-key "\C-j" 'sepia-scratch-send-line))
 613
 614 (defun sepia-scratch-send-line (&optional scalarp)
 615 "Send the current line to perl, and display the result."
 616   (interactive "P")
 617   (insert
 618    (sepia-eval (concat "do{"
 619                        (buffer-substring (my-bol-from (point))
 620                                          (my-eol-from (point)))
 621                        "}"))))
 622
 623 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 624 ;; Miscellany
 625
 626 (defun my-perl-frob-region (pre post beg end replace-p)
 627   (let* ((exp (concat pre "\""
 628                       (shell-quote-argument (buffer-substring beg end))
 629                       "\"" post))
 630          (new-str (format "%s" (perl-eval exp 'scalar-context))))
 631     (if replace-p
 632         (progn (delete-region beg end)
 633                (goto-char beg)
 634                (insert new-str))
 635         (message new-str))))
 636
 637 (defun my-eol-from (pt &optional n)
 638   (save-excursion
 639     (goto-char pt)
 640     (end-of-line n)
 641     (point)))
 642
 643 (defun my-bol-from (pt &optional n)
 644   (save-excursion
 645     (goto-char pt)
 646     (beginning-of-line n)
 647     (point)))
 648
 649 (defun perl-pe-region (expr beg end &optional replace-p)
 650 "Do the equivalent of perl -pe on region (i.e. evaluate an
 651 expression on each line of region).  With prefix arg, replace the
 652 region with the result."
 653   (interactive "MExpression:\nr\nP")
 654   (my-perl-frob-region
 655    "{ my $ret='';my $region = "
 656    (concat "; for (split /\n/, $region) { do { " expr
 657            ";}; $ret.=\"$_\\n\"}; $ret}")
 658    (my-bol-from beg) (my-eol-from end) replace-p))
 659
 660 (defun perl-ize-region (expr beg end &optional replace-p)
 661 "Evaluate a Perl expression on the region as a whole.  With
 662 prefix arg, replace the region with the result."
 663   (interactive "MExpression:\nr\nP")
 664   (my-perl-frob-region "{ local $_ = "
 665                        (concat "; do { " expr ";}; $_ }")
 666                        beg end replace-p))
 667
 668 (defun sepia-guess-package (sub &optional file)
 669   "Guess which package SUB is defined in."
 670   (let ((defs (xref-defs sub)))
 671     (or (and (= (length defs) 1)
 672              (or (not file) (equal (caar defs) file))
 673              (fourth (car defs)))
 674         (and file
 675              (fourth (find-if (lambda (x) (equal (car x) file)) defs)))
 676         (car (xref-file-modules file))
 677         (sepia-buffer-package))))
 678
 679 ;;;###autoload
 680 (defun sepia-eval-defun ()
 681   "Re-evaluate the current sub in the appropriate package, and
 682 rebuild its Xrefs."
 683   (interactive)
 684   (save-excursion
 685     (let ((beg (progn (beginning-of-defun) (point)))
 686           (end (progn (end-of-defun) (point))))
 687       (goto-char beg)
 688       (when (looking-at "^sub\\s +\\([^         {]+\\)")
 689         (let* ((sub (match-string 1))
 690                (sepia-eval-package
 691                 (sepia-guess-package sub (buffer-file-name)))
 692                (body (buffer-substring-no-properties beg end))
 693                (sepia-eval-file (buffer-file-name))
 694                (sepia-eval-line (line-number-at-pos beg)))
 695           (sepia-eval (if sepia-eval-defun-include-decls
 696                           (concat
 697                            (apply #'concat (xref-mod-decls sepia-eval-package))
 698                            body)
 699                           body))
 700           (xref-redefined sub sepia-eval-package)
 701           (message "Defined %s" sub))))))
 702
 703 (defun sepia-extract-def (file line obj mod)
 704   (with-current-buffer (find-file-noselect (expand-file-name file))
 705     (save-excursion
 706       (funcall (sepia-refiner 'function) line obj)
 707       (beginning-of-line)
 708       (when (looking-at (concat "^\\s *sub\\>.*\\<" obj "\\>"))
 709         (buffer-substring (point)
 710                           (progn (end-of-defun) (point)))))))
 711
 712 (defun sepia-eval-no-run (string)
 713   (condition-case err
 714       (sepia-eval
 715        (concat "BEGIN { use B; B::minus_c(); $^C=1; } { "
 716                string
 717                "} BEGIN { die \"ok\\n\" }"))
 718     (perl-error (if (string-match "^ok\n" (cadr err))
 719                     t
 720                     (cadr err)))
 721     (error err)))
 722
 723 ;;;###autoload
 724 (defun sepia-eval-buffer (&optional no-update)
 725   "Re-evaluate the current file; unless prefix argument is given,
 726 also rebuild the xref database."
 727   (interactive)
 728   (let ((sepia-eval-file (buffer-file-name)))
 729     (sepia-eval-no-run (buffer-string))
 730     (unless no-update
 731       (xref-rebuild))))
 732
 733 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 734 ;; REPL
 735
 736 (defvar sepia-eval-package "main"
 737   "Package in which ``sepia-eval'' evaluates perl expressions.")
 738 (defvar sepia-eval-file nil
 739   "File in which ``sepia-eval'' evaluates perl expressions.")
 740 (defvar sepia-eval-line nil
 741   "Line at which ``sepia-eval'' evaluates perl expressions.")
 742 (defvar sepia-repl-hook nil
 743   "Hook run after Sepia REPL starts.")
 744
 745 (defun sepia-repl-init-syntax ()
 746   (local-unset-key ":")
 747   (set-syntax-table cperl-mode-syntax-table)
 748   (modify-syntax-entry ?> "."))
 749
 750 (defun sepia-set-eval-package (new-package)
 751   (setq sepia-eval-package new-package))
 752
 753 (defun sepia-get-eval-package ()
 754   sepia-eval-package)
 755
 756 (defun sepia-eval (string &optional discard)
 757   "Evaluate STRING as Perl code, returning the pretty-printed
 758 value of the last expression.  If SOURCE-FILE is given, use this
 759 as the file containing the code to be evaluated.  XXX: this is
 760 the only function that requires EPL (the rest can use Pmacs)."
 761   (epl-eval (epl-init) nil 'scalar-context
 762   (concat
 763  "{ package " (or sepia-eval-package "main") ";"
 764  (if sepia-eval-file (concat "$Devel::Xref::file = \"" sepia-eval-file "\";")
 765      "")
 766  (if sepia-eval-line (format "$Devel::Xref::line = %d;" sepia-eval-line)
 767      "")
 768  (if discard
 769      (concat string "; 'ok' }\n")
 770      (concat
 771       "require Data::Dumper;"
 772 ;;       "local $Data::Dumper::Indent=0;"
 773       "local $Data::Dumper::Deparse=1;"
 774       "local $_ = Data::Dumper::Dumper([do { " string "}]);"
 775       "s/^.*?=\\s*\\[//; s/\\];$//;$_}")))))
 776
 777 ;;;###autoload
 778 (defun sepia-interact ()
 779 "Start or switch to a perl interaction buffer."
 780   (interactive)
 781   (unless (get-buffer "*perl-interaction*")
 782     (generic-repl "perl"))
 783   (pop-to-buffer (get-buffer "*perl-interaction*")))
 784
 785 (defun sepia-repl-header ()
 786   (let ((proc (aref perl-interpreter 2)))
 787     (format "%s [id=%d,d=%d,nr=%d] (%s)"
 788             (process-name proc)
 789             (process-id proc)
 790             (aref perl-interpreter 7)
 791             (aref perl-interpreter 5)
 792             (process-status proc))))
 793
 794 (defun sepia-set-repl-dir ()
 795   (interactive)
 796   (repl-cd default-directory "perl"))
 797
 798 (defun sepia-set-cwd (dir)
 799   (perl-call "chdir" dir))
 800
 801 (defun sepia-input-complete-p (beg end)
 802   (and (> end beg)
 803        (let ((res (sepia-eval-no-run (buffer-substring beg end))))
 804          (if (eq res t)
 805              t
 806              (message "[%s]" res)
 807              nil))))
 808
 809 (unless (assoc "perl" repl-supported-modes)
 810   (push '("perl"
 811           :map cperl-mode-map
 812           :eval sepia-eval
 813           :complete sepia-complete-symbol
 814           :header sepia-repl-header
 815           :cd sepia-set-cwd
 816           :init (lambda () (run-hooks 'sepia-repl-hook))
 817           :comment-start "#"
 818           :get-package sepia-get-eval-package
 819           :expression-p sepia-input-complete-p
 820           :set-package sepia-set-eval-package)
 821         repl-supported-modes))
 822
 823 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 824 ;; Doc-scanning
 825
 826 (defvar sepia-doc-map (make-hash-table :test #'equal))
 827 (defvar sepia-var-doc-map (make-hash-table :test #'equal))
 828 (defvar sepia-module-doc-map (make-hash-table :test #'equal))
 829
 830 ;; (defvar sepia-use-long-doc t
 831 ;;   "Gather additional docs from POD following =item to report with eldoc.")
 832
 833 (defun sepia-doc-scan-buffer ()
 834   (save-excursion
 835     (goto-char (point-min))
 836     (loop while (re-search-forward
 837                  "^=\\(item\\|head2\\)\\s +\\([%$&@A-Za-z_].*\\)" nil t)
 838        if (let* ((s1 (match-string 2))
 839                  (s2 (let ((case-fold-search nil))
 840                        (replace-regexp-in-string
 841                         "[A-Z]<\\([^>]+\\)>"
 842                         (lambda (x) (match-string 1 s1)) s1)))
 843                  (longdoc
 844                   (let ((beg (progn (forward-line 2) (point)))
 845                         (end (1- (re-search-forward "^=" nil t))))
 846                     (forward-line -1)
 847                     (goto-char beg)
 848                     (if (re-search-forward "^\\(.+\\)$" end t)
 849                         (concat s2 ": "
 850                                 (substring-no-properties
 851                                  (match-string 1)
 852                                  0 (position ?. (match-string 1))))
 853                         s2))))
 854             (cond
 855               ;; e.g. "C<foo(BLAH)>" or "$x = $y->foo()"
 856               ((string-match "\\(\\sw+\\)\\s *\\($\\|(\\)" s2)
 857                (list 'function (match-string-no-properties 1 s2)
 858                      (or (and (equal s2 (match-string 1 s2)) longdoc) s2)))
 859               ;; e.g. "$x -- this is x" (note: this has to come second)
 860               ((string-match "^[%$@]\\([^( ]+\\)" s2)
 861                (list 'variable (match-string-no-properties 1 s2) longdoc))))
 862        collect it)))
 863
 864 (defun sepia-buffer-package ()
 865   (save-excursion
 866     (goto-char (point-min))
 867     (or (and (re-search-forward "^\\s *package\\s +\\([^ ;]+\\)" nil t)
 868              (match-string 1))
 869         "main")))
 870
 871 (defun sepia-doc-update ()
 872 "Update documentation for a file.  This documentation, taken from
 873 \"=item\" entries in the POD, is used for eldoc feedback."
 874   (interactive)
 875   (let ((pack (ifa (or
 876                     (car (xref-file-modules (buffer-file-name)))
 877                     (sepia-buffer-package))
 878                    (concat it "::")
 879                    "")))
 880     (dolist (x (sepia-doc-scan-buffer))
 881       (let ((map (ecase (car x)
 882                    (function sepia-doc-map)
 883                    (variable sepia-var-doc-map))))
 884         (puthash (second x) (third x) map)
 885         (puthash (concat pack (second x)) (third x) map)))))
 886
 887 (defun sepia-symbol-info ()
 888 "Eldoc function for Sepia-mode.  Looks in ``sepia-doc-map'' and
 889 ``sepia-var-doc-map'', then tries calling
 890 ``cperl-describe-perl-symbol''."
 891   (save-excursion
 892     (multiple-value-bind (obj mod type) (sepia-ident-at-point)
 893       (or (and type
 894                (let ((map (ecase type
 895                             (function sepia-doc-map)
 896                             (variable sepia-var-doc-map)
 897                             (module sepia-module-doc-map))))
 898                  (if mod
 899                      (gethash mod map)
 900                      (gethash obj map))))
 901           (and obj
 902                ;; Loathe cperl a bit.
 903                (flet ((message (&rest blah) (apply #'format blah)))
 904                  (let* ((cperl-message-on-help-error nil)
 905                         (hlp (car (cperl-describe-perl-symbol obj))))
 906                    (when hlp
 907                      ;; cperl's docstrings are too long.
 908                      (setq hlp (replace-regexp-in-string "\\s \\{2,\\}" "  " hlp))
 909                      (if (> (length hlp) 75)
 910                          (concat (substring hlp 0 72) "...")
 911                          hlp)))))
 912           ""))))
 913
 914 (defun sepia-install-eldoc ()
 915 "Install Sepia hooks for eldoc support (probably requires Emacs >= 21.3)."
 916   (interactive)
 917   (set (make-variable-buffer-local
 918         'eldoc-print-current-symbol-info-function)
 919        #'sepia-symbol-info)
 920   (if cperl-lazy-installed (cperl-lazy-unstall))
 921   (eldoc-mode 1)
 922   (setq eldoc-idle-delay 1.0))
 923
 924 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 925 ;; Error jump:
 926
 927 (defun sepia-extract-next-warning (pos &optional end)
 928   (when (and (re-search-forward "^\\(.+\\) at \\(.+\\) line \\([0-9]+\\)\\.$"
 929                                 end t)
 930              (not (string= "(eval " (substring (match-string 2) 0 6))))
 931     (list (match-string 2)
 932           (read-from-string (match-string 3))
 933           (msg (match-string 1)))))
 934
 935 (defun sepia-goto-error-at (pos)
 936   "Visit the source of the error on line at POS (point if called
 937 interactively)."
 938   (interactive "d")
 939   (ifa (sepia-extract-warning (my-bol-from pos) (my-eol-from pos))
 940        (destructuring-bind (file line msg) it
 941          (find-file file)
 942          (goto-line line)
 943          (message "%s" msg))
 944        (error "No error to find.")))
 945
 946 (defun sepia-perl-display-errors (beg end)
 947   (interactive "r")
 948   (goto-char beg)
 949   (loop with msgs = (make-hash-table :test #'equal)
 950      for w = (sepia-extract-warning (my-bol-from (point)) end)
 951      while w
 952      do (destructuring-bind (file line msg) w
 953           (puthash file msgs (cons line msg)))
 954      finally
 955        (with-current-buffer (get-buffer-create "*perl-warnings*")
 956          (let ((inhibit-read-only t))
 957            (erase-buffer))
 958          (dolist (k (sort (hash-table-keys msgs) #'string<))
 959            (let ((v (gethash k msgs)))
 960              (insert (format "%s:%d:\n%s\n"
 961                              (abbreviate-file-name k) (car v) (cdr v)))))
 962          (goto-char (point-min))
 963          (grep-mode))))
 964
 965 (provide 'sepia)
 966 ;;; sepia.el ends here