sepia.el

   1 ;;; Sepia -- Simple Emacs-Perl InterAction: ugly, yet effective.
   2 ;;; (a.k.a. Septik -- Sean's Emacs-Perl Total Integration Kludge.)
   3
   4 ;; Copyright (C) 2004-2007 Sean O'Rourke.  All rights reserved, some
   5 ;; wrongs reversed.  This code is distributed under the same terms as
   6 ;; Perl itself.
   7
   8 ;;; Commentary:
   9
  10 ;; See the README file that comes with the distribution.
  11
  12 ;;; Code:
  13
  14 (require 'cperl-mode)
  15 (require 'comint)
  16 (require 'cl)
  17 ;; try optional modules, but don't bitch if we fail:
  18 (require 'sepia-w3m nil t)
  19 (require 'sepia-tree nil t)
  20 (require 'sepia-ido nil t)
  21
  22 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23 ;;; Comint communication
  24
  25 (defvar sepia-perl5lib nil
  26 "* Extra PERL5LIB directory for Sepia.pm")
  27
  28 (defvar sepia-program-name "perl"
  29 "* Perl program name.")
  30
  31 (defvar sepia-perldoc-function
  32   (if (featurep 'w3m) 'w3m-perldoc 'cperl-perldoc)
  33 "* Function to view modules' documentation.
  34
  35 Useful values include `w3m-perldoc' and `cperl-perldoc'.")
  36
  37 (defvar sepia-view-pod-function
  38   (if (featurep 'w3m) 'sepia-w3m-view-pod 'sepia-perldoc-buffer)
  39 "* Function to view modules' documentation.
  40
  41 Useful values include `sepia-w3m-view-pod' and `sepia-perldoc-buffer'.")
  42
  43 (defvar sepia-module-list-function
  44   (if (featurep 'w3m) 'w3m-find-file 'browse-url-of-buffer)
  45 "* Function to view a list of installed modules.
  46
  47 Useful values include `w3m-find-file' and `browse-url-of-buffer'.")
  48
  49 (defvar sepia-process nil
  50 "The perl process with which we're interacting.")
  51 (defvar sepia-output nil
  52 "Current perl output for a response to `sepia-eval-raw', appended
  53 to by `perl-collect-output'.")
  54 (defvar sepia-passive-output ""
  55 "Current perl output for miscellaneous user interaction, used to
  56 look for \";;;###\" lisp evaluation markers.")
  57
  58 (defvar sepia-perl-builtins nil
  59 "List of Perl builtins for completion.")
  60
  61 (defun sepia-collect-output (string)
  62 "Collect perl output for `sepia-eval-raw' into sepia-output."
  63   (setq sepia-output (concat sepia-output string))
  64   "")
  65
  66 (defun sepia-eval-raw (str)
  67 "Evaluate perl code STR, returning a pair (RESULT-STRING . OUTPUT)."
  68   (let (ocpof)
  69     (unwind-protect
  70          (let ((sepia-output "")
  71                (start 0))
  72            (with-current-buffer (process-buffer sepia-process)
  73              (setq ocpof comint-preoutput-filter-functions
  74                    comint-preoutput-filter-functions '(sepia-collect-output)))
  75            (setq str (concat "local $Sepia::STOPDIE=0;"
  76                              "local $Sepia::STOPWARN=0;"
  77                              "{ package " (sepia-buffer-package) ";"
  78                              str " }\n"))
  79            (comint-send-string sepia-process
  80                                (concat (format "<<%d\n" (length str)) str))
  81            (while (not (and sepia-output
  82                             (string-match "> $" sepia-output)))
  83              (accept-process-output sepia-process))
  84            (if (string-match "^;;;[0-9]+\n" sepia-output)
  85                (cons
  86                 (let* ((x (read-from-string sepia-output
  87                                             (+ (match-beginning 0) 3)))
  88                        (len (car x))
  89                        (pos (cdr x)))
  90                   (prog1 (substring sepia-output (1+ pos) (+ len pos 1))
  91                     (setq start (+ pos len 1))))
  92                 (and (string-match ";;;[0-9]+\n" sepia-output start)
  93                      (let* ((x (read-from-string
  94                                 sepia-output
  95                                 (+ (match-beginning 0) 3)))
  96                             (len (car x))
  97                             (pos (cdr x)))
  98                        (substring sepia-output (1+ pos) (+ len pos 1)))))
  99                (cons sepia-output nil)))
 100       (with-current-buffer (process-buffer sepia-process)
 101         (setq comint-preoutput-filter-functions ocpof)))))
 102
 103 (defun sepia-eval (str &optional context detailed)
 104 "Evaluate STR in CONTEXT (void by default), and return its result
 105 as a Lisp object.  If DETAILED is specified, return a
 106 pair (RESULT . OUTPUT)."
 107   (let* ((tmp (sepia-eval-raw
 108                (case context
 109                  (list-context
 110                   (concat "Sepia::tolisp([" str "])"))
 111                  (scalar-context
 112                   (concat "Sepia::tolisp(scalar(" str "))"))
 113                  (t (concat str ";1")))))
 114          (res (car tmp))
 115          (errs (cdr tmp)))
 116     (setq res (if context
 117                   (if (string= res "") "" (car (read-from-string res)))
 118                   1))
 119     (if detailed
 120         (cons res errs)
 121         res)))
 122
 123 (defun sepia-call (fn context &rest args)
 124 "Call perl function FN in CONTEXT with arguments ARGS, returning
 125 its result as a Lisp value."
 126   (sepia-eval (concat fn "(" (mapconcat #'sepia-lisp-to-perl args ", ") ")")
 127               context))
 128
 129 (defun sepia-watch-for-eval (string)
 130 "Monitor inferior Perl output looking for Lisp evaluation
 131 requests.  The format for these requests is
 132 \"\\n;;;###LENGTH\\nDATA\".  Only one such request can come from
 133 each inferior Perl prompt."
 134   (setq sepia-passive-output (concat sepia-passive-output string))
 135   (cond
 136     ((string-match "^;;;###[0-9]+" sepia-passive-output)
 137      (when (string-match "^;;;###\\([0-9]+\\)\n\\(?:.\\|\n\\)*\\(\n.*> \\)"
 138                          sepia-passive-output)
 139        (let* ((len (car (read-from-string
 140                          (match-string 1 sepia-passive-output))))
 141               (pos (1+ (match-end 1)))
 142               (res (ignore-errors (eval (car (read-from-string
 143                                               sepia-passive-output pos
 144                                               (+ pos len)))))))
 145          (insert (format "%s => %s\n"
 146                          (substring sepia-passive-output pos (+ pos len)) res))
 147          (goto-char (point-max))
 148          (comint-set-process-mark)
 149          (sepia-eval "''" 'scalar-context)
 150          (message "%s => %s" (substring sepia-passive-output pos (+ pos len))
 151                   res)
 152          (setq sepia-passive-output "")))
 153      "")
 154     (t (setq sepia-passive-output "") string)))
 155
 156 (defun sepia-install-keys (&optional map)
 157   "Install Sepia bindings in the current local keymap."
 158   (interactive)
 159   (let ((map (or map (current-local-map))))
 160     (define-key map sepia-prefix-key sepia-metapoint-map)
 161     (define-key map "\M-," 'sepia-next)
 162     (define-key map "\C-\M-x" 'sepia-eval-defun)
 163     (define-key map "\C-c\C-l" 'sepia-load-file)
 164     (define-key map "\C-c\C-d" 'sepia-view-pod)
 165     (define-key map (kbd "TAB") 'sepia-indent-or-complete)))
 166
 167 (defun sepia-comint-setup ()
 168 "Set up the inferior Perl process buffer."
 169   (comint-mode)
 170   (set (make-local-variable 'comint-dynamic-complete-functions)
 171        '(sepia-complete-symbol comint-dynamic-complete-filename))
 172   (set (make-local-variable 'comint-preoutput-filter-functions)
 173        '(sepia-watch-for-eval))
 174   (set (make-local-variable 'comint-use-prompt-regexp) t)
 175   (modify-syntax-entry ?: "_")
 176   (modify-syntax-entry ?> ".")
 177   (use-local-map (copy-keymap (current-local-map)))
 178   (sepia-install-keys)
 179   (local-set-key (kbd "TAB") 'comint-dynamic-complete)
 180   (local-set-key "\C-a" 'comint-bol)
 181   (set (make-local-variable 'comint-prompt-regexp)
 182        "^[^>\n]*> *")
 183   )
 184
 185 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 186 ;;; Keymaps, user variables, setup.
 187
 188 (defvar sepia-use-completion t
 189   "* Use completion based on Xref database.  Turning this off may
 190 speed up some operations, if you don't mind losing completion.")
 191
 192 (defvar sepia-eval-defun-include-decls t
 193   "* Generate and use a declaration list for ``sepia-eval-defun''.
 194 Without this, code often will not parse; with it, evaluation may
 195 be a bit less responsive.  Note that since this only includes
 196 subs from the evaluation package, it may not always work.")
 197
 198 (defvar sepia-prefix-key "\M-."
 199   "* Prefix for functions in ``sepia-keymap''.")
 200
 201 ;;;###autoload
 202 (defun sepia-perldoc-this (name)
 203   "View perldoc for module at point."
 204   (interactive (list (sepia-interactive-arg 'module)))
 205   (funcall sepia-perldoc-function name))
 206
 207 (defun sepia-view-pod ()
 208   "View POD for the current buffer."
 209   (interactive)
 210   (funcall sepia-view-pod-function))
 211
 212 (defun sepia-module-list ()
 213   "List installed modules with links to their documentation.
 214
 215 This lists not just top-level packages appearing in packlist
 216 files, but all documented modules on the system, organized by
 217 package."
 218   (interactive)
 219   (let ((file "/tmp/modlist.html"))
 220     ;; (unless (file-exists-p file)
 221     (sepia-eval-raw (format "Sepia::html_module_list(\"%s\")" file))
 222     (funcall sepia-module-list-function file)))
 223
 224 (defun sepia-package-list ()
 225   "List installed packages with links to their documentation.
 226
 227 This lists only top-level packages appearing in packlist files.
 228 For modules within packages, see `sepia-module-list'."
 229   (interactive)
 230   (let ((file "/tmp/packlist.html"))
 231     ;; (unless (file-exists-p file)
 232     (sepia-eval-raw (format "Sepia::html_package_list(\"%s\")" file))
 233     (funcall sepia-module-list-function file)))
 234
 235 (defun sepia-perldoc-buffer ()
 236   "View current buffer's POD using pod2html and `browse-url'."
 237   (let ((buffer (get-buffer-create "*sepia-pod*"))
 238         (errs (get-buffer-create "*sepia-pod-errors*"))
 239         (inhibit-read-only t))
 240     (with-current-buffer buffer (erase-buffer))
 241     (save-window-excursion
 242       (shell-command-on-region (point-min) (point-max) "pod2html"
 243                                buffer nil errs))
 244     (with-current-buffer buffer (browse-url-of-buffer))))
 245
 246 (defun sepia-perl-name (sym &optional mod)
 247 "Convert a Perl name to a Lisp name."
 248   (setq sym (substitute ?_ ?- (if (symbolp sym) (symbol-name sym) sym)))
 249   (if mod
 250       (concat mod "::" sym)
 251       sym))
 252
 253 ;;;###autoload
 254 (defun sepia-repl ()
 255   "Start the Sepia REPL."
 256   (interactive)
 257   (sepia-init) ;; set up keymaps, etc.
 258   (unless (and (processp sepia-process)
 259                (eq (process-status sepia-process) 'run))
 260     (setq sepia-process
 261           (get-buffer-process
 262            (comint-exec (get-buffer-create "*sepia-repl*")
 263                         "perl" sepia-program-name nil
 264                         (append (mapcar (lambda (x) (concat "-I" x))
 265                                         sepia-perl5lib)
 266                                 '("-MData::Dumper" "-MSepia" "-MSepia::Xref"
 267                                   "-e" "Sepia::repl(*STDIN)")))))
 268       (with-current-buffer "*sepia-repl*"
 269         (sepia-comint-setup))
 270       (accept-process-output sepia-process 0 1))
 271   (pop-to-buffer (get-buffer "*sepia-repl*")))
 272
 273 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 274 ;;; Xref
 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 (sepia-perl-name name package)))
 280     (fmakunbound lisp-name)
 281     (eval `(defun ,lisp-name (&rest args)
 282              ,doc
 283              (apply #'sepia-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 (sepia-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               (sepia-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
 309 (defvar sepia-history nil)
 310
 311 (defun sepia-interactive-arg (&optional type)
 312 "Default argument for most Sepia functions.  TYPE is a symbol --
 313 either 'file to look for a file, or anything else to use the
 314 symbol at point."
 315   (let* ((default (case type
 316                     (file (or (thing-at-point 'file) (buffer-file-name)))
 317                     (t (sepia-thing-at-point 'symbol))))
 318          (text (capitalize (symbol-name type)))
 319          (choices (lambda (str &rest blah)
 320                     (let ((str (concat "^" str)))
 321                       (case type
 322                         (variable (xref-var-apropos str))
 323                         (function (xref-apropos str))
 324                         (module (xref-mod-apropos str))
 325                         (t nil)))))
 326          (ret (if sepia-use-completion
 327                   (completing-read (format "%s [%s]: " text default)
 328                                    choices nil nil nil 'sepia-history
 329                                    default)
 330                   (read-string (format "%s [%s]: " text default)
 331                                nil 'sepia-history default))))
 332     (push ret sepia-history)
 333     ret))
 334
 335 (defun sepia-interactive-module ()
 336 "Guess which module we should look things up in.  Prompting for a
 337 module all the time is a PITA, but I don't think this (choosing
 338 the current file's module) is a good alternative, either.  Best
 339 would be to choose the module based on what we know about the
 340 symbol at point."
 341   (let ((xs (xref-file-modules (buffer-file-name))))
 342     (if (= (length xs) 1)
 343         (car xs)
 344         nil)))
 345
 346 (defun sepia-maybe-echo (result)
 347   (when (interactive-p)
 348     (message "%s" result))
 349   result)
 350
 351 (defun sepia-find-module-file (mod)
 352   (or (sepia-module-file mod)
 353       (car (xref-guess-module-file mod))))
 354
 355 (defun sepia-module-find (mod)
 356 "Find the file defining module MOD."
 357   (interactive (list (sepia-interactive-arg 'module)))
 358   (let ((fn (sepia-find-module-file mod)))
 359     (when fn
 360       (message "Module %s in %s." mod fn)
 361       (pop-to-buffer (find-file-noselect (expand-file-name fn))))))
 362
 363 (defmacro ifa (test then &rest else)
 364   `(let ((it ,test))
 365      (if it ,then ,@else)))
 366
 367 (defvar sepia-found-refiner)
 368
 369 (defun sepia-show-locations (locs)
 370   (when locs
 371     (pop-to-buffer (get-buffer-create "*sepia-places*"))
 372     (let ((inhibit-read-only t))
 373       (erase-buffer)
 374       (dolist (loc (sort (remove nil locs) ; XXX where's nil from?
 375                          (lambda (a b)
 376                            (or (string< (car a) (car b))
 377                                (and (string= (car a) (car b))
 378                                     (< (second a) (second b)))))))
 379         (destructuring-bind (file line name &rest blah) loc
 380           (let ((str (ifa (find-buffer-visiting file)
 381                           (with-current-buffer it
 382                             (ifa sepia-found-refiner
 383                                  (funcall it line name)
 384                                  (goto-line line))
 385                             (message "line for %s was %d, now %d" name line
 386                                      (line-number-at-pos))
 387                             (setq line (line-number-at-pos))
 388                             (let ((tmpstr
 389                                    (buffer-substring (sepia-bol-from (point))
 390                                                      (sepia-eol-from (point)))))
 391                               (if (> (length tmpstr) 60)
 392                                   (concat "\n    " tmpstr)
 393                                   tmpstr)))
 394                           "...")))
 395             (insert (format "%s:%d:%s\n" (abbreviate-file-name file) line str)))))
 396       (grep-mode)
 397       (goto-char (point-min)))))
 398
 399 (defmacro define-sepia-query (name doc &optional gen test prompt)
 400   "Define a sepia querying function."
 401   `(defun ,name (ident &optional module file line display-p)
 402      ,(concat doc "
 403
 404 With prefix arg, list occurences in a ``grep-mode'' buffer.
 405 Without, place the occurrences on ``sepia-found'', so that
 406 calling ``sepia-next'' will cycle through them.
 407
 408 Depending on the query, MODULE, FILE, and LINE may be used to
 409 narrow the results, as long as doing so leaves some matches.
 410 When called interactively, they are taken from the current
 411 buffer.
 412 ")
 413      (interactive (list (sepia-interactive-arg ,(or prompt ''function))
 414                         (sepia-interactive-module)
 415                         (buffer-file-name)
 416                         (line-number-at-pos (point))
 417                         current-prefix-arg
 418                         ))
 419      (let ((ret
 420             ,(if test
 421                  `(let ((tmp (,gen ident module file line)))
 422                     (or (mapcan #',test tmp) tmp))
 423                  `(,gen ident module file line))))
 424        ;; Always clear out the last found ring, because it's confusing
 425        ;; otherwise.
 426        (sepia-set-found nil ',(or prompt 'function))
 427        (if display-p
 428            (sepia-show-locations ret)
 429            (sepia-set-found ret ',(or prompt 'function))
 430            (sepia-next)))))
 431
 432
 433 (define-sepia-query sepia-defs
 434     "Find all definitions of sub."
 435   xref-apropos
 436   xref-location)
 437
 438 (define-sepia-query sepia-callers
 439     "Find callers of FUNC."
 440   xref-callers
 441   xref-location)
 442
 443 (define-sepia-query sepia-callees
 444     "Find a sub's callees."
 445   xref-callees
 446   xref-location)
 447
 448 (define-sepia-query sepia-var-defs
 449     "Find a var's definitions."
 450   xref-var-defs
 451   (lambda (x) (setf (third x) ident) (list x))
 452   'variable)
 453
 454 (define-sepia-query sepia-var-uses
 455     "Find a var's uses."
 456   xref-var-uses
 457   (lambda (x) (setf (third x) ident) (list x))
 458   'variable)
 459
 460 (define-sepia-query sepia-var-assigns
 461     "Find/list assignments to a variable."
 462   xref-var-assigns
 463   (lambda (x) (setf (third x) ident) (list x))
 464   'variable)
 465
 466 (define-sepia-query sepia-module-describe
 467     "Find all subroutines in a package."
 468   xref-mod-subs
 469   nil
 470   'module)
 471
 472 (defalias 'sepia-package-defs 'sepia-module-describe)
 473
 474 (define-sepia-query sepia-apropos
 475     "Find/list subroutines matching regexp."
 476   (lambda (name &rest blah) (xref-apropos name 1))
 477   xref-location
 478   'function)
 479
 480 (define-sepia-query sepia-var-apropos
 481     "Find/list variables matching regexp."
 482   xref-var-apropos
 483   xref-var-defs
 484   'variable)
 485
 486 (defun sepia-location (name &optional jump-to)
 487   "Find the definition of NAME.
 488
 489 When called interactively (or with JUMP-TO true), go directly
 490 to this location."
 491   (interactive (list (or (thing-at-point 'symbol)
 492                          (completing-read "Function: " 'xref-completions))
 493                      t))
 494   (let* ((fl (or (car (xref-location name))
 495                  (car (remove-if #'null
 496                                  (apply #'xref-location (xref-apropos name)))))))
 497     (when (and fl (string-match "^(eval " (car fl)))
 498       (message "Can't find definition of %s in %s." name (car fl))
 499       (setq fl nil))
 500     (if jump-to
 501         (if fl (progn
 502                  (sepia-set-found (list fl) 'function)
 503                  (sepia-next))
 504             (message "No definition for %s." name))
 505         fl)))
 506
 507 ;;;###autoload
 508 (defun sepia-dwim (&optional display-p)
 509     "Try to do the right thing with identifier at point.
 510 * Find all definitions, if thing-at-point is a function
 511 * Find all uses, if thing-at-point is a variable
 512 * Find documentation, if thing-at-point is a module
 513 * Prompt otherwise
 514 "
 515     (interactive "P")
 516     (multiple-value-bind (type obj) (sepia-ident-at-point)
 517       (sepia-set-found nil type)
 518       (let* ((module-doc-p nil)
 519              (ret
 520               (cond
 521                 ((member type '(?% ?$ ?@)) (xref-var-defs obj))
 522                 ((or (equal type ?&)
 523                      (let (case-fold-search)
 524                        (string-match "^[^A-Z]" obj)))
 525                  (list (sepia-location obj)))
 526                 ((sepia-looks-like-module obj)
 527                  (setq module-doc-p t)
 528                  `((,(sepia-perldoc-this obj) 1 nil nil)))
 529                 (t (setq module-doc-p t)
 530                    (call-interactively 'sepia-defs)))))
 531         (unless module-doc-p
 532           (if display-p
 533               (sepia-show-locations ret)
 534               (sepia-set-found ret type)
 535               (sepia-next))))))
 536
 537 (defun sepia-rebuild ()
 538   "Rebuild the Xref database."
 539   (interactive)
 540   (xref-rebuild))
 541
 542 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 543 ;;; Perl motion commands.
 544
 545 ;;; XXX -- these are a hack to prevent infinite recursion calling
 546 ;;; e.g. beginning-of-defun from beginning-of-defun-function.
 547 ;;; `beginning-of-defun' should handle this.
 548 (defmacro sepia-safe-bodf (&optional n)
 549   `(let ((beginning-of-defun-function
 550           (if (and (boundp 'beginning-of-defun-function)
 551                    (eq beginning-of-defun-function 'sepia-beginning-of-defun))
 552               nil
 553               beginning-of-defun-function)))
 554      (beginning-of-defun ,n)))
 555
 556 (defmacro sepia-safe-eodf (&optional n)
 557   `(let ((end-of-defun-function
 558           (if (and (boundp 'end-of-defun-function)
 559                    (eq end-of-defun-function 'sepia-end-of-defun))
 560               nil
 561               end-of-defun-function)))
 562      (end-of-defun ,n)))
 563
 564 (defun sepia-beginning-of-defun (&optional n)
 565 "Move to beginning of current function.
 566
 567 If prefix argument given, move N functions backward."
 568   (interactive "p")
 569   (let ((here (point)))
 570     (beginning-of-line)
 571     (if (and (not (= here (point)))
 572              (looking-at sepia-sub-re))
 573         (point)
 574         (sepia-safe-bodf n)
 575         (let* ((end (point))
 576                (beg (progn (forward-line -3) (point))))
 577           (goto-char end)
 578           (re-search-backward sepia-sub-re beg t)))))
 579
 580 (defun sepia-end-of-defun (&optional n)
 581   "Move to end of current function.
 582
 583 If prefix argument given, move N functions forward."
 584   (interactive "p")
 585   (let ((here (point)))
 586     ;; (sepia-safe-bodf)
 587     (when (looking-at sepia-sub-re)
 588       (forward-line 1))
 589     (sepia-safe-eodf n)
 590     (when (and (>= here (point))
 591                (re-search-forward sepia-sub-re nil t))
 592       (sepia-safe-eodf))
 593     (point)))
 594
 595 (defun sepia-defun-around-point (&optional where)
 596   "Return the text of function around point."
 597   (interactive "d")
 598   (unless where
 599     (setq where (point)))
 600   (save-excursion
 601     (goto-char where)
 602     (and (sepia-beginning-of-defun)
 603          (match-string-no-properties 1))))
 604
 605 (defun sepia-lexicals-at-point (&optional where)
 606   "Find lexicals in scope at point."
 607   (interactive "d")
 608   (unless where
 609     (setq where (point)))
 610   (let ((subname (sepia-defun-around-point where))
 611         (mod (sepia-buffer-package)))
 612     (xref-lexicals (sepia-perl-name subname mod))))
 613
 614 ;;;###autoload
 615 (defun sepia-load-file (file &optional rebuild-p collect-warnings)
 616   "Reload a file (interactively, the current buffer's file).
 617
 618 With REBUILD-P (or a prefix argument when called interactively),
 619 also rebuild the xref database."
 620   (interactive (list (expand-file-name (buffer-file-name))
 621                      prefix-arg
 622                      (format "*%s errors*" (buffer-file-name))))
 623   (save-buffer)
 624   (let* ((tmp (sepia-eval (format "do '%s' || ($@ && die $@)" file)
 625                           'scalar-context t))
 626          (res (car tmp))
 627          (errs (cdr tmp)))
 628     (message "sepia: %s returned %s" (abbreviate-file-name file) res)
 629     (when (and collect-warnings
 630                (> (length errs) 1))
 631       (with-current-buffer (get-buffer-create collect-warnings)
 632         (let ((inhibit-read-only t))
 633           (delete-region (point-min) (point-max))
 634           (insert errs)
 635           (sepia-display-errors (point-min) (point-max))
 636           (pop-to-buffer (current-buffer))))))
 637   (when rebuild-p
 638     (xref-rebuild)))
 639
 640 (defvar sepia-found)
 641 (defvar sepia-found-head)
 642
 643 (defun sepia-set-found (list &optional type)
 644   (setq list
 645         (remove-if (lambda (x)
 646                      (or (not x)
 647                          (and (not (car x)) (string= (fourth x) "main"))))
 648                    list))
 649   (setq sepia-found list
 650         sepia-found-head list)
 651   (setq sepia-found-refiner (sepia-refiner type)))
 652
 653 (defun sepia-refiner (type)
 654   (case type
 655     (function
 656      (lambda (line ident)
 657       (let ((sub-re (concat "^\\s *sub\\s +.*" ident "\\_>")))
 658         ;; Test this because sometimes we get lucky and get the line
 659         ;; just right, in which case beginning-of-defun goes to the
 660         ;; previous defun.
 661         (unless (looking-at sub-re)
 662           (or (and line
 663                    (progn
 664                      (goto-line line)
 665                      (beginning-of-defun)
 666                      (looking-at sub-re)))
 667               (progn (goto-char (point-min))
 668                      (re-search-forward sub-re nil t)))
 669           (beginning-of-line)))))
 670     ;; Old version -- this may actually work better if
 671     ;; beginning-of-defun goes flaky on us.
 672 ;;         (or (re-search-backward sub-re
 673 ;;                                 (sepia-bol-from (point) -20) t)
 674 ;;             (re-search-forward sub-re
 675 ;;                                (sepia-bol-from (point) 10) t))
 676 ;;         (beginning-of-line)
 677     (variable
 678      (lambda (line ident)
 679        (let ((var-re (concat "\\_<" ident "\\_>")))
 680          (cond
 681            (line (goto-line line)
 682                  (or (re-search-backward var-re (sepia-bol-from (point) -5) t)
 683                      (re-search-forward var-re (sepia-bol-from (point) 5) t)))
 684            (t (goto-char (point-min))
 685               (re-search-forward var-re nil t))))))
 686     (t (lambda (line ident) (and line (goto-line line))))))
 687
 688 (defun sepia-next ()
 689 "Go to the next thing (e.g. def, use) found by sepia."
 690   (interactive)
 691   (if sepia-found
 692       (destructuring-bind (file line short &optional mod &rest blah)
 693           (car sepia-found)
 694         (unless file
 695           (setq file (and mod (sepia-find-module-file mod)))
 696           (if file
 697               (setf (caar sepia-found) file)
 698               (error "No file for %s." (car sepia-found))))
 699         (message "%s at %s:%s" short file line)
 700         (when (file-exists-p file)
 701           (find-file (or file (sepia-find-module-file mod)))
 702           (when sepia-found-refiner
 703             (funcall sepia-found-refiner line short))
 704           (beginning-of-line)
 705           (recenter)
 706           (setq sepia-found (or (cdr sepia-found)
 707                                 sepia-found-head))))
 708       (message "No more definitions.")))
 709
 710 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 711 ;; Completion
 712
 713 (defun sepia-ident-before-point ()
 714   "Find the Perl identifier at or preceding point."
 715   (save-excursion
 716     (when (looking-at "[%$@*&]")
 717       (forward-char 1))
 718     (let* ((end (point))
 719            (beg (progn
 720                  (when (re-search-backward "[^A-Za-z_0-9:]" nil 'mu)
 721                    (forward-char 1))
 722                  (point)))
 723            (sigil (if (= beg (point-min))
 724                       nil
 725                       (char-before (point)))))
 726       (list (when (member sigil '(?$ ?@ ?% ?* ?&)) sigil)
 727             (buffer-substring-no-properties beg end)))))
 728
 729 (defvar sepia-complete-methods t
 730 "* Non-nil if Sepia should try to complete methods for \"$x->\".
 731
 732 NOTE: this feature can be problematic, since it evaluates the
 733 object in order to find its type.  Currently completion is only
 734 attempted for objects that are simple scalars.")
 735
 736 (defun sepia-simple-method-before-point ()
 737   "Find the \"simple\" method call before point.
 738
 739 Looks for a simple method called on a variable before point and
 740 returns the list (OBJECT METHOD).  For example, \"$x->blah\"
 741 returns '(\"$x\" \"blah\").  Only simple methods are recognized,
 742 because completing anything evaluates it, so completing complex
 743 expressions would lead to disaster."
 744   (when sepia-complete-methods
 745     (let ((end (point))
 746           (bound (max (- (point) 100) (point-min)))
 747           arrow beg)
 748       (save-excursion
 749         ;; XXX - can't do this because COMINT's syntax table is weird.
 750         ;; (skip-syntax-backward "_w")
 751         (skip-chars-backward "a-zA-Z0-9_")
 752         (when (looking-back "->\\s *" bound)
 753           (setq arrow (search-backward "->" bound))
 754           (skip-chars-backward "a-zA-Z0-9_:")
 755           (cond
 756             ;; $x->method
 757             ((char-equal (char-before (point)) ?$)
 758              (setq beg (1- (point))))
 759             ;; X::Class->method
 760             ((sepia-looks-like-module (thing-at-point 'symbol))
 761              (setq beg (point))))
 762           (when beg
 763             (list (buffer-substring-no-properties beg arrow)
 764                   (buffer-substring-no-properties (+ 2 arrow) end)
 765                   (buffer-substring-no-properties beg end))))))))
 766
 767 (defun sepia-ident-at-point ()
 768   "Find the Perl identifier at point."
 769   (save-excursion
 770     (when (looking-at "[%$@*&]")
 771       (forward-char 1))
 772     (let* ((beg (progn
 773                  (when (re-search-backward "[^A-Za-z_0-9:]" nil 'mu)
 774                    (forward-char 1))
 775                  (point)))
 776           (sigil (if (= beg (point-min))
 777                      nil
 778                      (char-before (point))))
 779           (end (progn
 780                  (when (re-search-forward "[^A-Za-z_0-9:]" nil 'mu)
 781                    (forward-char -1))
 782                  (point))))
 783       (list (when (member sigil '(?$ ?@ ?% ?* ?&)) sigil)
 784             (buffer-substring-no-properties beg end)))))
 785
 786 (defun sepia-function-at-point ()
 787   "Find the Perl function called at point."
 788   (condition-case nil
 789       (save-excursion
 790         (let ((pt (point))
 791               bof)
 792           (sepia-beginning-of-defun)
 793           (setq bof (point))
 794           (goto-char pt)
 795           (sepia-end-of-defun)
 796           (when (and (>= pt bof) (< pt (point)))
 797             (goto-char bof)
 798             (looking-at "\\s *sub\\s +")
 799             (forward-char (length (match-string 0)))
 800             (concat (or (sepia-buffer-package) "")
 801                     "::"
 802                     (cadr (sepia-ident-at-point))))))
 803     (error nil)))
 804
 805 (defun sepia-complete-symbol ()
 806   "Try to complete the word at point.
 807 The word may be either a global variable if it has a
 808 sigil (sorry, no lexicals), a module, or a function.  The
 809 function currently ignores module qualifiers, which may be
 810 annoying in larger programs.
 811
 812 The function is intended to be bound to \\M-TAB, like
 813 ``lisp-complete-symbol''."
 814   (interactive)
 815   (let ((win (get-buffer-window "*Completions*" 0))
 816         len
 817         completions
 818         type
 819         meth)
 820     (if (and (eq last-command this-command)
 821              win (window-live-p win) (window-buffer win)
 822              (buffer-name (window-buffer win)))
 823
 824         ;; If this command was repeated, and
 825         ;; there's a fresh completion window with a live buffer,
 826         ;; and this command is repeated, scroll that window.
 827         (with-current-buffer (window-buffer win)
 828           (if (pos-visible-in-window-p (point-max) win)
 829               (set-window-start win (point-min))
 830               (save-selected-window
 831                 (select-window win)
 832                 (scroll-up))))
 833
 834         ;; Otherwise actually do completion:
 835         ;; 1 - Look for a method call:
 836         (setq meth (sepia-simple-method-before-point))
 837         (when meth
 838           (setq len (length (caddr meth))
 839                 completions (xref-method-completions
 840                              (cons 'expr (format "'%s'" (car meth)))
 841                              (cadr meth)
 842                              "Sepia::repl_eval")
 843                 type (format "%s->" (car meth))))
 844         (multiple-value-bind (typ name) (sepia-ident-before-point)
 845           ;; 2 - look for a regular function/variable/whatever
 846           (unless completions
 847             (setq type typ
 848                   len (+ (if type 1 0) (length name))
 849                   completions (xref-completions
 850                                name
 851                                (case type
 852                                  (?$ "VARIABLE")
 853                                  (?@ "ARRAY")
 854                                  (?% "HASH")
 855                                  (?& "CODE")
 856                                  (?* "IO")
 857                                  (t ""))
 858                                (unless (eq major-mode 'comint-mode)
 859                                  (sepia-function-at-point)))))
 860           ;; 3 - try a Perl built-in
 861           (when (and (not completions)
 862                      (or (not type) (eq type ?&)))
 863             (when (string-match ".*::([^:]+)$" name)
 864               (setq name (match-string 1 name)))
 865             (setq completions (all-completions name sepia-perl-builtins)))
 866           (case (length completions)
 867             (0 (message "No completions for %s." name) nil)
 868             (1 ;; XXX - skip sigil to match s-i-before-point
 869              (when (looking-at "[%$@*&]")
 870                (forward-char 1))
 871              (delete-region (- (point) len) (point))
 872              (insert (or type "") (car completions))
 873              ;; Hide stale completions buffer (stolen from lisp.el).
 874              (if win (with-selected-window win (bury-buffer))) t)
 875             (t (let ((old name)
 876                      (new (try-completion "" completions)))
 877                  (if (<= (length new) (length old))
 878                      (with-output-to-temp-buffer "*Completions*"
 879                        (display-completion-list completions))
 880                      (let ((win (get-buffer-window "*Completions*" 0)))
 881                        (if win (with-selected-window win (bury-buffer))))
 882                      (delete-region (- (point) len) (point))
 883                      (insert (or type "") new))))))
 884         t)))
 885
 886 (defvar sepia-indent-expand-abbrev t
 887 "* If non-NIL, `sepia-indent-or-complete' tries `expand-abbrev'.")
 888
 889 (defun sepia-indent-or-complete ()
 890 "Indent the current line or complete the symbol around point.
 891
 892 Specifically, try completion when indentation doesn't move point.
 893 This function is intended to be bound to TAB."
 894   (interactive)
 895   (let ((pos (point)))
 896     (let (beginning-of-defun-function
 897           end-of-defun-function)
 898       (cperl-indent-command))
 899     (when (and (= pos (point))
 900                (not (bolp))
 901                (or (eq last-command 'sepia-indent-or-complete)
 902                    (looking-at "\\_>")))
 903       (when (or (not sepia-indent-expand-abbrev)
 904                (expand-abbrev))
 905         (sepia-complete-symbol)))))
 906
 907 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 908 ;;; scratchpad code
 909
 910 (defvar sepia-mode-map nil "Keymap for Sepia mode.")
 911
 912 (defvar sepia-metapoint-map nil
 913   "Keymap for Sepia functions.  This is just an example of how you
 914 might want to bind your keys, which works best when bound to
 915 `\\M-.'.")
 916
 917 ;;;###autoload
 918 (define-derived-mode sepia-mode cperl-mode "Sepia"
 919   "Major mode for Perl editing, derived from cperl mode.
 920 \\{sepia-mode-map}"
 921   (sepia-init)
 922   (sepia-install-eldoc)
 923   (sepia-doc-update)
 924   (set (make-local-variable 'beginning-of-defun-function)
 925        'sepia-beginning-of-defun)
 926   (set (make-local-variable 'end-of-defun-function)
 927        'sepia-end-of-defun)
 928   (sepia-init))
 929
 930 (defun sepia-init ()
 931   "Perform the initialization necessary to start Sepia."
 932   (unless sepia-metapoint-map
 933     ;; first time!
 934     (setq sepia-metapoint-map (make-sparse-keymap))
 935     (dolist (kv '(("c" . sepia-callers)
 936                   ("C" . sepia-callees)
 937                   ("a" . sepia-apropos)
 938                   ("A" . sepia-var-apropos)
 939                   ("v" . sepia-var-uses)
 940                   ("V" . sepia-var-defs)
 941                   ;;              ("V" . sepia-var-assigns)
 942                   ("\M-." . sepia-dwim)
 943                   ;; ("\M-." . sepia-location)
 944                   ("l" . sepia-location)
 945                   ("f" . sepia-defs)
 946                   ("r" . sepia-rebuild)
 947                   ("m" . sepia-module-find)
 948                   ("n" . sepia-next)
 949                   ("t" . find-tag)
 950                   ("d" . sepia-perldoc-this)))
 951       (define-key sepia-metapoint-map (car kv) (cdr kv)))
 952     (when (featurep 'ido)
 953       (define-key sepia-metapoint-map "j" 'sepia-jump-to-symbol)))
 954   (unless sepia-mode-map
 955     (setq sepia-mode-map (make-sparse-keymap))
 956     ;; Undo annoying binding of C-h, which breaks key help.  Move it
 957     ;; elsewhere?
 958     (define-key sepia-mode-map "\C-c\C-h" nil)
 959     ;; (define-key sepia-mode-map "\C-chF" 'cperl-info-on-command)
 960     ;; (define-key sepia-mode-map "\C-cha" 'cperl-toggle-autohelp)
 961     ;; (define-key sepia-mode-map "\C-chf" 'cperl-info-on-current-command)
 962     ;; (define-key sepia-mode-map "\C-chm" 'sepia-perldoc-this)
 963     ;; (define-key sepia-mode-map "\C-chv" 'cperl-get-help)
 964
 965     (sepia-install-keys sepia-mode-map)
 966     ;; Load perl defs:
 967     ;; Create glue wrappers for Module::Info funcs.
 968     (dolist (x '((name "Find module name.\n\nDoes not require loading.")
 969                  (version "Find module version.\n\nDoes not require loading.")
 970                  (inc-dir "Find directory in which this module was found.\n\nDoes not require loading.")
 971                  (file "Absolute path of file defining this module.\n\nDoes not require loading.")
 972                  (is-core "Guess whether or not a module is part of the core distribution.
 973 Does not require loading.")
 974                  (modules-used "List modules used by this module.\n\nRequires loading.")
 975                  (packages-inside "List sub-packages in this module.\n\nRequires loading.")
 976                  (superclasses "List module's superclasses.\n\nRequires loading.")))
 977       (apply #'define-modinfo-function x))
 978
 979     ;; Create low-level wrappers for Sepia
 980     (dolist (x '((completions "Find completions in the symbol table.")
 981                  (method-completions "Complete on an object's methods.")
 982                  (location "Find an identifier's location.")
 983                  (mod-subs "Find all subs defined in a package.")
 984                  (mod-decls "Generate declarations for subs in a package.")
 985                  (mod-file "Find the file defining a package.")
 986                  (apropos "Find subnames matching RE.")
 987                  (lexicals "Find lexicals for a sub.")
 988                  ))
 989       (apply #'define-xref-function "Sepia" x))
 990
 991     (dolist (x '((rebuild "Build Xref database for current Perl process.")
 992                  (redefined "Rebuild Xref information for a given sub.")
 993
 994                  (callers "Find all callers of a function.")
 995                  (callees "Find all functions called by a function.")
 996
 997                  (var-apropos "Find varnames matching RE.")
 998                  (mod-apropos "Find modules matching RE.")
 999                  (file-apropos "Find files matching RE.")
1000
1001                  (var-defs "Find all definitions of a variable.")
1002                  (var-assigns "Find all assignments to a variable.")
1003                  (var-uses "Find all uses of a variable.")
1004
1005                  (mod-redefined "Rebuild Xref information for a given package.")
1006                  (guess-module-file "Guess file corresponding to module.")
1007                  (file-modules "List the modules defined in a file.")))
1008       (apply #'define-xref-function "Sepia::Xref" x))
1009
1010     ;; Initialize built hash
1011     (sepia-init-perl-builtins)))
1012
1013 ;;;###autoload
1014 (define-derived-mode sepia-scratchpad-mode sepia-mode "Sepia-Scratch"
1015   "Major mode for the Perl scratchpad, derived from Sepia mode."
1016   (define-key sepia-scratchpad-mode-map "\C-j" 'sepia-scratch-send-line))
1017
1018 ;;;###autoload
1019 (defun sepia-scratch ()
1020   "Switch to the sepia scratchpad."
1021   (interactive)
1022   (pop-to-buffer
1023    (or (get-buffer "*sepia-scratch*")
1024        (with-current-buffer (get-buffer-create "*sepia-scratch*")
1025          (sepia-scratchpad-mode)
1026          (current-buffer)))))
1027
1028 (defun sepia-scratch-send-line (&optional scalarp)
1029   "Send the current line to perl, and display the result."
1030   (interactive "P")
1031   (insert "\n"
1032    (format "%S" (sepia-eval-raw (concat "scalar do{"
1033                        (buffer-substring (sepia-bol-from (point))
1034                                          (sepia-eol-from (point)))
1035                        "}")))
1036    "\n"))
1037
1038 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1039 ;; Miscellany
1040
1041 (defun sepia-perlize-region-internal (pre post beg end replace-p)
1042   "Pass buffer text from BEG to END through a Perl command."
1043   (let* ((exp (concat pre "<<'SEPIA_END_REGION';\n"
1044                       (buffer-substring-no-properties beg end)
1045                       (if (= (char-before end) ?\n) "" "\n")
1046                       "SEPIA_END_REGION\n" post))
1047          (new-str (sepia-eval-raw exp)))
1048     (if replace-p
1049         (progn (delete-region beg end)
1050                (goto-char beg)
1051                (insert new-str))
1052         (message new-str))))
1053
1054 (defun sepia-eol-from (pt &optional n)
1055   (save-excursion
1056     (goto-char pt)
1057     (end-of-line n)
1058     (point)))
1059
1060 (defun sepia-bol-from (pt &optional n)
1061   (save-excursion
1062     (goto-char pt)
1063     (beginning-of-line n)
1064     (point)))
1065
1066 (defun sepia-perl-pe-region (expr beg end &optional replace-p)
1067   "Do the equivalent of perl -pe on region
1068
1069 \(i.e. evaluate an expression on each line of region).  With
1070 prefix arg, replace the region with the result."
1071   (interactive "MExpression: \nr\nP")
1072   (sepia-perlize-region-internal
1073    "do { my $ret='';my $region = "
1074    (concat "; for (split /\n/, $region) { do { " expr
1075            ";}; $ret.=\"$_\\n\"}; $ret}")
1076    (sepia-bol-from beg) (sepia-eol-from end) replace-p))
1077
1078 (defun sepia-perl-ne-region (expr beg end &optional replace-p)
1079   "Do the moral equivalent of perl -ne on region
1080
1081 \(i.e. evaluate an expression on each line of region).  With
1082 prefix arg, replace the region with the result."
1083   (interactive "MExpression:\nr\nP")
1084   (sepia-perlize-region-internal
1085    "do { my $ret='';my $region = "
1086    (concat "; for (split /\n/, $region) { $ret .= do { " expr
1087            ";} }; ''.$ret}")
1088    (sepia-bol-from beg) (sepia-eol-from end) replace-p))
1089
1090 (defun sepia-perlize-region (expr beg end &optional replace-p)
1091   "Evaluate a Perl expression on the region as a whole.
1092
1093 With prefix arg, replace the region with the result."
1094   (interactive "MExpression:\nr\nP")
1095   (sepia-perlize-region-internal
1096    "do { local $_ = " (concat "; do { " expr ";}; $_ }") beg end replace-p))
1097
1098 (defun sepia-core-version (module &optional message)
1099   "Report the first version of Perl shipping with MODULE."
1100   (interactive (list (read-string "Module: "
1101                                   nil nil (sepia-thing-at-point 'symbol))
1102                      t))
1103   (let* ((version
1104           (sepia-eval
1105            (format "eval { Sepia::core_version('%s') }" module)
1106            'scalar-context))
1107          (res (if version
1108                   (format "%s was first released in %s." module version)
1109                   (format "%s is not in core." module))))
1110     (when message (message "%s" res))
1111     res))
1112
1113 (defun sepia-guess-package (sub &optional file)
1114   "Guess which package SUB is defined in."
1115   (let ((defs (xref-location (xref-apropos sub))))
1116     (or (and (= (length defs) 1)
1117              (or (not file) (equal (caar defs) file))
1118              (fourth (car defs)))
1119         (and file
1120              (fourth (find-if (lambda (x) (equal (car x) file)) defs)))
1121         (car (xref-file-modules file))
1122         (sepia-buffer-package))))
1123
1124 ;;;###autoload
1125 (defun sepia-eval-defun ()
1126   "Re-evaluate the current function and rebuild its Xrefs."
1127   (interactive)
1128   (save-excursion
1129     (let* ((pt (point))
1130            (end (progn (end-of-defun) (point)))
1131            (beg (progn (goto-char pt) (beginning-of-defun) (point))))
1132       (goto-char beg)
1133       (when (looking-at "^sub\\s +\\(.+\\_>\\)")
1134         (let* ((sub (match-string 1))
1135                (sepia-eval-package
1136                 (sepia-guess-package sub (buffer-file-name)))
1137                (body (buffer-substring-no-properties beg end))
1138                (sepia-eval-file (buffer-file-name))
1139                (sepia-eval-line (line-number-at-pos beg)))
1140           (sepia-eval (if sepia-eval-defun-include-decls
1141                           (concat
1142                            (apply #'concat (xref-mod-decls sepia-eval-package))
1143                            body)
1144                           body))
1145           (xref-redefined sub sepia-eval-package)
1146           (message "Defined %s" sub))))))
1147
1148 ;;;###autoload
1149 (defun sepia-eval-expression (expr &optional list-p message-p)
1150   "Evaluate EXPR in scalar context."
1151   (interactive (list (read-string "Expression: ") current-prefix-arg t))
1152   (let ((res (sepia-eval expr (if list-p 'list-context 'scalar-context))))
1153     (when message-p (message "%s" res))
1154     res))
1155
1156 (defun sepia-extract-def (file line obj mod)
1157   (with-current-buffer (find-file-noselect (expand-file-name file))
1158     (save-excursion
1159       (funcall (sepia-refiner 'function) line obj)
1160       (beginning-of-line)
1161       (when (looking-at (concat "^\\s *sub\\_>.*\\_<" obj "\\_>"))
1162         (buffer-substring (point)
1163                           (progn (end-of-defun) (point)))))))
1164
1165 (defun sepia-eval-no-run (string)
1166   (let ((res (sepia-eval-raw
1167               (concat "eval q#{ BEGIN { use B; B::minus_c(); $^C=1; } do { "
1168                       string
1169                       " };BEGIN { die \"ok\\n\" }#, $@"))))
1170     (if (string-match "^ok\n" (car res))
1171         nil
1172         (car res))))
1173
1174 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1175 ;; REPL
1176
1177 (defvar sepia-eval-file nil
1178   "File in which ``sepia-eval'' evaluates perl expressions.")
1179 (defvar sepia-eval-line nil
1180   "Line at which ``sepia-eval'' evaluates perl expressions.")
1181
1182 (defun sepia-set-cwd (dir)
1183   (interactive (list default-directory))
1184   (sepia-call "Cwd::chdir" dir))
1185
1186 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1187 ;; Doc-scanning
1188
1189 (defvar sepia-doc-map (make-hash-table :test #'equal))
1190 (defvar sepia-var-doc-map (make-hash-table :test #'equal))
1191 (defvar sepia-module-doc-map (make-hash-table :test #'equal))
1192
1193 (defun sepia-doc-scan-buffer ()
1194   (save-excursion
1195     (goto-char (point-min))
1196     (loop while (re-search-forward
1197                  "^=\\(item\\|head[2-9]\\)\\s +\\([%$&@A-Za-z_].*\\)" nil t)
1198        if (ignore-errors
1199             (let* ((s1 (match-string 2))
1200                    (s2 (let ((case-fold-search nil))
1201                          (replace-regexp-in-string
1202                           "[A-Z]<\\([^>]+\\)>" "\\1" s1)))
1203                    (longdoc
1204                     (let ((beg (progn (forward-line 2) (point)))
1205                           (end (1- (re-search-forward "^=" nil t))))
1206                       (forward-line -1)
1207                       (goto-char beg)
1208                       (if (re-search-forward "^\\(.+\\)$" end t)
1209                           (concat s2 ": "
1210                                   (substring-no-properties
1211                                    (match-string 1)
1212                                    0 (position ?. (match-string 1))))
1213                           s2))))
1214               (cond
1215                 ;; e.g. "$x -- this is x"
1216                 ((string-match "^[%$@]\\([A-Za-z0-9_:]+\\)\\s *--\\s *\\(.*\\)"
1217                                s2)
1218                  (list 'variable (match-string-no-properties 1 s2)
1219                        (or (and (equal s2 (match-string 1 s2)) longdoc) s2)))
1220                 ;; e.g. "C<foo(BLAH)>" or "$x = $y->foo()"
1221                 ((string-match "\\([A-Za-z0-9_:]+\\)\\s *\\(\\$\\|(\\)" s2)
1222                  (list 'function (match-string-no-properties 1 s2)
1223                        (or (and (equal s2 (match-string 1 s2)) longdoc) s2)))
1224                 ;; e.g. "$x this is x" (note: this has to come last)
1225                 ((string-match "^[%$@]\\([^( ]+\\)" s2)
1226                  (list 'variable (match-string-no-properties 1 s2) longdoc)))))
1227        collect it)))
1228
1229 (defun sepia-buffer-package ()
1230   (save-excursion
1231     (or (and (re-search-backward "^\\s *package\\s +\\([^ ;]+\\)\\s *;" nil t)
1232              (match-string-no-properties 1))
1233         "main")))
1234
1235 (defun sepia-doc-update ()
1236   "Update documentation for a file.
1237
1238 This documentation, taken from \"=item\" entries in the POD, is
1239 used for eldoc feedback."
1240   (interactive)
1241   (let ((pack (ifa (sepia-buffer-package) (concat it "::") "")))
1242     (dolist (x (sepia-doc-scan-buffer))
1243       (let ((map (ecase (car x)
1244                    (function sepia-doc-map)
1245                    (variable sepia-var-doc-map))))
1246         (puthash (second x) (third x) map)
1247         (puthash (concat pack (second x)) (third x) map)))))
1248
1249 (defun sepia-looks-like-module (obj)
1250   (let (case-fold-search)
1251     (or (string-match "^\\([A-Z].*::\\)?[A-Z]+[a-z]+\\sw*$" obj)
1252         (string-match
1253          (eval-when-compile (regexp-opt '("strict" "vars" "warnings" "lib")))
1254          obj))))
1255
1256 (defun sepia-symbol-info (&optional obj type)
1257   "Eldoc function for Sepia-mode.
1258
1259 Looks in ``sepia-doc-map'' and ``sepia-var-doc-map'', then tries
1260 calling ``cperl-describe-perl-symbol''."
1261   (unless obj
1262     (multiple-value-bind (ty ob) (sepia-ident-at-point)
1263       (setq obj (if (consp ob) (car ob) ob)
1264             type ty)))
1265   (if obj
1266       (or (gethash obj (ecase (or type ?&)
1267                          (?& sepia-doc-map)
1268                          ((?$ ?@ ?%) sepia-var-doc-map)
1269                          (nil sepia-module-doc-map)))
1270           ;; Loathe cperl a bit.
1271           (flet ((message (&rest blah) (apply #'format blah)))
1272             (let* (case-fold-search
1273                    (cperl-message-on-help-error nil)
1274                    (hlp (car (cperl-describe-perl-symbol obj))))
1275               (if hlp
1276                   (progn
1277                     ;; cperl's docstrings are too long.
1278                     (setq hlp (replace-regexp-in-string "\\s \\{2,\\}" "  " hlp))
1279                     (if (> (length hlp) 75)
1280                         (concat (substring hlp 0 72) "...")
1281                         hlp))
1282                   ;; Try to see if it's a module
1283                   (if (sepia-looks-like-module obj)
1284                       (sepia-core-version obj)
1285                       ""))))
1286       "")))
1287
1288 (defun sepia-install-eldoc ()
1289   "Install Sepia hooks for eldoc support."
1290   (interactive)
1291   (require 'eldoc)
1292   (set-variable 'eldoc-documentation-function 'sepia-symbol-info t)
1293   (if cperl-lazy-installed (cperl-lazy-unstall))
1294   (eldoc-mode 1)
1295   (set-variable 'eldoc-idle-delay 1.0 t))
1296
1297 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1298 ;; Error jump:
1299
1300 (defun sepia-extract-next-warning (pos &optional end)
1301   (catch 'foo
1302     (while (re-search-forward "^\\(.+\\) at \\(.+?\\) line \\([0-9]+\\)"
1303                               end t)
1304       (unless (string= "(eval " (substring (match-string 2) 0 6))
1305         (throw 'foo (list (match-string 2)
1306                           (parse-integer (match-string 3))
1307                           (match-string 1)))))))
1308
1309 (defun sepia-goto-error-at (pos)
1310   "Visit the source of the error on line at point."
1311   (interactive "d")
1312   (ifa (sepia-extract-next-warning (sepia-bol-from pos) (sepia-eol-from pos))
1313        (destructuring-bind (file line msg) it
1314          (find-file file)
1315          (goto-line line)
1316          (message "%s" msg))
1317        (error "No error to find.")))
1318
1319 (defun sepia-display-errors (beg end)
1320   "Display source causing errors in current buffer from BEG to END."
1321   (interactive "r")
1322   (goto-char beg)
1323   (let ((msgs nil))
1324     (loop for w = (sepia-extract-next-warning (sepia-bol-from (point)) end)
1325        while w
1326        do (destructuring-bind (file line msg) w
1327             (push (format "%s:%d:%s\n" (abbreviate-file-name file) line msg)
1328                   msgs)))
1329     (erase-buffer)
1330     (goto-char (point-min))
1331     (mapcar #'insert (nreverse msgs))
1332     (goto-char (point-min))
1333     (grep-mode)))
1334
1335 (defun sepia-lisp-to-perl (thing)
1336   "Convert elisp data structure to Perl."
1337   (cond
1338     ((null thing) "undef")
1339     ((symbolp thing)
1340      (let ((pname (substitute ?_ ?- (symbol-name thing)))
1341            (type (string-to-char (symbol-name thing))))
1342        (if (member type '(?% ?$ ?@ ?*))
1343            pname
1344            (concat "\\*" pname))))
1345     ((stringp thing) (format "\'%s\'" thing))
1346     ((integerp thing) (format "%d" thing))
1347     ((numberp thing) (format "%g" thing))
1348     ;; Perl expression
1349     ((and (consp thing) (eq (car thing) 'expr))
1350      (cdr thing))        ; XXX -- need quoting??
1351     ((and (consp thing) (not (consp (cdr thing))))
1352      (concat (sepia-lisp-to-perl (car thing)) " => "
1353              (sepia-lisp-to-perl (cdr thing))))
1354     ;; list
1355     ((or (not (consp (car thing)))
1356          (listp (cdar thing)))
1357      (concat "[" (mapconcat #'sepia-lisp-to-perl thing ", ") "]"))
1358     ;; hash table
1359     (t
1360      (concat "{" (mapconcat #'sepia-lisp-to-perl thing ", ") "}"))))
1361
1362 (defun sepia-init-perl-builtins ()
1363   (setq sepia-perl-builtins (make-hash-table))
1364   (dolist (s '("abs"
1365 "accept"
1366 "alarm"
1367 "atan2"
1368 "bind"
1369 "binmode"
1370 "bless"
1371 "caller"
1372 "chdir"
1373 "chmod"
1374 "chomp"
1375 "chop"
1376 "chown"
1377 "chr"
1378 "chroot"
1379 "close"
1380 "closedir"
1381 "connect"
1382 "continue"
1383 "cos"
1384 "crypt"
1385 "dbmclose"
1386 "dbmopen"
1387 "defined"
1388 "delete"
1389 "die"
1390 "dump"
1391 "each"
1392 "endgrent"
1393 "endhostent"
1394 "endnetent"
1395 "endprotoent"
1396 "endpwent"
1397 "endservent"
1398 "eof"
1399 "eval"
1400 "exec"
1401 "exists"
1402 "exit"
1403 "exp"
1404 "fcntl"
1405 "fileno"
1406 "flock"
1407 "fork"
1408 "format"
1409 "formline"
1410 "getc"
1411 "getgrent"
1412 "getgrgid"
1413 "getgrnam"
1414 "gethostbyaddr"
1415 "gethostbyname"
1416 "gethostent"
1417 "getlogin"
1418 "getnetbyaddr"
1419 "getnetbyname"
1420 "getnetent"
1421 "getpeername"
1422 "getpgrp"
1423 "getppid"
1424 "getpriority"
1425 "getprotobyname"
1426 "getprotobynumber"
1427 "getprotoent"
1428 "getpwent"
1429 "getpwnam"
1430 "getpwuid"
1431 "getservbyname"
1432 "getservbyport"
1433 "getservent"
1434 "getsockname"
1435 "getsockopt"
1436 "glob"
1437 "gmtime"
1438 "goto"
1439 "grep"
1440 "hex"
1441 "import"
1442 "index"
1443 "int"
1444 "ioctl"
1445 "join"
1446 "keys"
1447 "kill"
1448 "last"
1449 "lc"
1450 "lcfirst"
1451 "length"
1452 "link"
1453 "listen"
1454 "local"
1455 "localtime"
1456 "log"
1457 "lstat"
1458 "map"
1459 "mkdir"
1460 "msgctl"
1461 "msgget"
1462 "msgrcv"
1463 "msgsnd"
1464 "next"
1465 "oct"
1466 "open"
1467 "opendir"
1468 "ord"
1469 "pack"
1470 "package"
1471 "pipe"
1472 "pop"
1473 "pos"
1474 "print"
1475 "printf"
1476 "prototype"
1477 "push"
1478 "quotemeta"
1479 "rand"
1480 "read"
1481 "readdir"
1482 "readline"
1483 "readlink"
1484 "readpipe"
1485 "recv"
1486 "redo"
1487 "ref"
1488 "rename"
1489 "require"
1490 "reset"
1491 "return"
1492 "reverse"
1493 "rewinddir"
1494 "rindex"
1495 "rmdir"
1496 "scalar"
1497 "seek"
1498 "seekdir"
1499 "select"
1500 "semctl"
1501 "semget"
1502 "semop"
1503 "send"
1504 "setgrent"
1505 "sethostent"
1506 "setnetent"
1507 "setpgrp"
1508 "setpriority"
1509 "setprotoent"
1510 "setpwent"
1511 "setservent"
1512 "setsockopt"
1513 "shift"
1514 "shmctl"
1515 "shmget"
1516 "shmread"
1517 "shmwrite"
1518 "shutdown"
1519 "sin"
1520 "sleep"
1521 "socket"
1522 "socketpair"
1523 "sort"
1524 "splice"
1525 "split"
1526 "sprintf"
1527 "sqrt"
1528 "srand"
1529 "stat"
1530 "study"
1531 "sub"
1532 "sub*"
1533 "substr"
1534 "symlink"
1535 "syscall"
1536 "sysopen"
1537 "sysread"
1538 "sysseek"
1539 "system"
1540 "syswrite"
1541 "tell"
1542 "telldir"
1543 "tie"
1544 "tied"
1545 "time"
1546 "times"
1547 "truncate"
1548 "uc"
1549 "ucfirst"
1550 "umask"
1551 "undef"
1552 "unlink"
1553 "unpack"
1554 "unshift"
1555 "untie"
1556 "utime"
1557 "values"
1558 "vec"
1559 "wait"
1560 "waitpid"
1561 "wantarray"
1562 "warn"
1563 "write"
1564 ))
1565         (puthash s t sepia-perl-builtins)))
1566
1567 (provide 'sepia)
1568 ;;; sepia.el ends here