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