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