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