Changeset 19252 for lang/elisp/perl-completion/branch/1.0/perl-completion.el

Timestamp:

09/13/08 03:07:59 (4 months ago)

Author:

imakado

Message:

インストールされているモジュールの補完候補収得部分の非同期化。モードの状態変更時に補完候補が無い場合、補完候補の収得プロセスを非同期につくりステータスをみてキャッシュする

Files:

• lang/elisp/perl-completion/branch/1.0/perl-completion.el (modified) (28 diffs)

lang/elisp/perl-completion/branch/1.0/perl-completion.el

@@ -35 +35 @@
 
 
+;; TODO:
+;; set-perl5lib
+
 
 ;;;code:
 (require 'cl)
-(require 'anything)
+(require 'anything) ; perl-completion.el uses `anything-aif' macro.
 (require 'cperl-mode)
 (require 'dabbrev)
@@ -49 +52 @@
 ;;; variables
 (defvar plcmp-version 1.0)
+
 (defvar plcmp-perl-ident-re "[a-zA-Z_][a-zA-Z_0-9]*")
+
 (defvar plcmp-sub-re (rx-to-string `(and "sub"
                                         (+ space)
                                         (group
                                          (regexp ,plcmp-perl-ident-re)))))
+
 (defvar plcmp-perl-package-re "[a-zA-Z0-9:]+")
+
 (defvar plcmp-builtin-functions
   '("abs" "exec" "glob" "order" "seek" "symlink" "accept" "exists" "gmtime"
@@ -109 +116 @@
     "$PREMATCH" "$&" "$MATCH" "$<digits>" "$b" "$a" "$_" "$ARG"))
 
-(defvar plcmp-cleanup-hook nil "hook run when completion command finished")
+(defvar plcmp--command-cleanup-hook nil "hook run when completion command finished")
+
+(defvar plcmp--cached-variables nil "list of cached variable. each variable is cleared by `plcmp-cmd-clear-all-caches'")
+
 
 ;;; macros
-
-(defmacro plcmp-aif (test-form then-form &optional else-form)
-  "Anaphoric if. Temporary variable `it' is the result of test-form."
-  `(let ((it ,test-form))
-     (if it ,then-form ,else-form)))
-(put 'plcmp-aif 'lisp-indent-function 2)
-
-
 (defmacro define-plcmp-command (command-name-with-no-prefix args &rest body)
   (let* ((prefix "plcmp-cmd-")
@@ -171 +173 @@
         default-directory))))
 
-(defun plcmp-re-sort-sources (re sources)
-  "regexp RE にnameがマッチするsourceを先頭に並び替えたsourcesを返す"
-  (let ((match-source
-         (find-if (lambda (source)
-                    (let* ((source (if (listp source) source (symbol-value source)))
-                           (name (assoc-default 'name source 'eq)))
-                      (when (string-match re name)
-                        source)))
-                  sources)))
-    (if match-source
-        (cons match-source (remove match-source sources))
-      sources)))
+;; TODO: need test.
+(defsubst plcmp--re-match-sources1 (regexps source)
+  (when source
+    (let ((source (if (listp source) source (symbol-value source))))
+      (some (lambda (re)
+              (string-match re (assoc-default 'name source 'eq)))
+            regexps))))
+
+(defun plcmp-re-sort-sources (regexps sources)
+  (condition-case e
+      (let ((regexps (if (stringp regexps) (list regexps) regexps))
+            (match-sources)
+            (unmatch-sources))
+        (loop for source in sources
+              if (plcmp--re-match-sources1 regexps source)
+              collect source into match-sources
+              else
+              collect source into unmatch-sources
+              finally (return (nconc match-sources unmatch-sources))))
+    (error sources)))
+;;(plcmp-re-sort-sources "variable" (plcmp-get-sources-for-complete-all))
+
+(defun* plcmp-collect-matches
+    (re &optional (count 0) (match-string-fn 'match-string)
+        (point-min (point-min)) (point-max (point-max)))
+  (save-excursion
+    (loop initially (goto-char point-min)
+          while (re-search-forward re point-max t)
+          collect (funcall match-string-fn count))))
 
 ;;; log
@@ -199 +218 @@
           (insert strn)))
       str)))
+(defun plcmp-message (&rest args)
+  (when plcmp-debug
+    (apply 'message args)))
 
 
 (defvar plcmp-initial-input "")
 (defvar plcmp-real-initial-input "real initial-input if required `anything-match-plugin' initial-input is not real initial-input")
-(defun plcmp-get-initial-input ()
-  (let ((initial-input (buffer-substring-no-properties
-                        (point)
-                        (save-excursion (skip-syntax-backward "w_")
-                                        (point)))))
-    (setq plcmp-real-initial-input initial-input) ;; `plcmp-insert'
-    (concat initial-input
-            (if (featurep 'anything-match-plugin)
-                " "
-              ""))))
+(defun plcmp-get-initial-real-input-list ()
+  "return list (initial-input real-initial-input)"
+  (save-excursion
+    (let ((start (point)))
+      (skip-syntax-backward "w_")
+      (let* ((preceding-string (char-to-string (preceding-char)))
+             (end (condition-case e
+                      (cond
+                       ((some (lambda (s) (string-equal s preceding-string)) '("$" "@" "&" "&"))
+                        (backward-char)
+                        (point))
+                       (t
+                        (point)))
+                    (error (point))))
+             (real-initial-input
+              (buffer-substring-no-properties start end))
+             (initial-input
+              (regexp-quote
+               (concat real-initial-input
+                       (if (featurep 'anything-match-plugin)
+                           " "
+                         "")))))
+        (values initial-input real-initial-input)))))
 
 ;;; installed modules
 (defvar plcmp-installed-modules nil)
+(add-to-list 'plcmp--cached-variables 'plcmp-installed-modules)
+
 (defun plcmp-get-installed-modules ()
-  (or plcmp-installed-modules
-      (setq plcmp-installed-modules (plcmp--installed-modules-synchronously))))
+  (unless (plcmp-tramp-p)
+    (or plcmp-installed-modules
+        (prog1 (plcmp--installed-modules-synchronously)
+          (plcmp--installed-modules-asynchronously)))))
 
 (defun plcmp--installed-modules-synchronously ()
-  (unless (plcmp-tramp-p)
-    (message "fetching installed modules...")
-    (let* ((modules-str (shell-command-to-string
-                         (concat
-                          "find `perl -e 'pop @INC; print join(q{ }, @INC);'`"
-                          " -name '*.pm' -type f "
-                          "| xargs egrep -h -o 'package [a-zA-Z0-9:]+;' "
-                          "| perl -nle 's/package\s+(.+);/$1/; print' "
-                          "| sort "
-                          "| uniq ")))
-           (modules (split-string modules-str "\n")))
-      (message "done")
-      (remove-if (lambda (module)
-                   (string-match "No such file or directory$" module))
-                 modules))))
-
+  (message "fetching installed modules...")
+  (let* ((modules-str (shell-command-to-string
+                       (concat
+                        "find `perl -e 'pop @INC; print join(q{ }, @INC);'`"
+                        " -name '*.pm' -type f "
+                        "| xargs egrep -h -o 'package [a-zA-Z0-9:]+;' "
+                        "| perl -nle 's/package\s+(.+);/$1/; print' "
+                        "| sort "
+                        "| uniq ")))
+         (modules (split-string modules-str "\n")))
+    (message "done")
+    (remove-if (lambda (module)
+                 (string-match "No such file or directory$" module))
+               modules)))
+
+(defvar plcmp-installed-modules-buffer-name " *perl-completion installed modules*")
+(defun plcmp--installed-modules-set-cache (process event)
+  (when (string-equal "finished\n" event)
+    (with-current-buffer plcmp-installed-modules-buffer-name
+      (unless (zerop (buffer-size))
+        (setq plcmp-installed-modules (plcmp-collect-matches plcmp-perl-package-re))
+        (plcmp-message "cached installed modules %s" plcmp-installed-modules)))))
+
+(defun plcmp--installed-modules-asynchronously ()
+  "start process, set sentinel, return process."
+  (message "fetching installed modules...")
+  (let* ((command "find")
+         (args (concat "find `perl -e 'pop @INC; print join(q{ }, @INC);'`"
+                       " -name '*.pm' -type f "
+                       "| xargs grep -E -h -o 'package [a-zA-Z0-9:]+;' "
+                       "| perl -nle 's/package\s+(.+);/$1/; print' "
+                       "| sort "
+                       "| uniq "))
+         (proc (start-process-shell-command "installed perl modules"
+                                            plcmp-installed-modules-buffer-name
+                                            command
+                                            args)))
+    (set-process-sentinel proc 'plcmp--installed-modules-set-cache)
+    ;; return process
+    proc))
+
+;;  (plcmp--installed-modules-asynchronously)
+
+
+;; todo: ne (length plcmp--installed-modules-synchronously)
+(defun plcmp--installed-modules-perl ()
+  (let* ((str (shell-command-to-string (concat " perl -e ' use File::Find; @dirs = grep { q{.} ne $_} @INC"
+                                               "; my $dir_name = $dir"
+                                               " ;my $mods = sub { if ( -f && /.pm$/ ) { print $File::Find::name, \"\n\"; } }; find $mods, @dirs; ' ")))
+         (files (delete-dups (delete "" (delete "." (split-string str "\n"))))))
+    (loop for file in files
+          collect (plcmp--package-name file))))
+
+(defun plcmp--package-name (file)
+  (let ((re (rx-to-string `(and "package"
+                                  (+ space)
+                                  (group
+                                   (regexp ,plcmp-perl-package-re))
+                                  (* space)
+                                  ";"
+                                  ))))
+    (when (and (stringp file)
+               (file-exists-p file)
+               (file-readable-p file))
+      (with-temp-buffer
+        (insert-file-contents file)
+        (goto-char (point-min))
+        (when (re-search-forward re nil t)
+         (match-string-no-properties 1))))))
+  
 ;;; current package
 (defvar plcmp-current-package-name "")
@@ -257 +350 @@
 (defvar plcmp-using-modules nil)
 (defun plcmp-get-using-modules ()
-  (let* ((re (rx-to-string `(and bol
-                                 (* space)
-                                 "use"
-                                 (+ space)
-                                 (group
-                                  (regexp ,plcmp-perl-package-re))
-                                 (* not-newline)
-                                 ";"))))
-    (save-excursion
-      (loop initially (goto-char (point-min))
-            while (re-search-forward re nil t)
-            collect (match-string-no-properties 1)))))
+  (let ((re (rx-to-string `(and bol
+                                (* space)
+                                "use"
+                                (+ space)
+                                (group  ;1 package
+                                 (regexp ,plcmp-perl-package-re))
+                                (* not-newline)
+                                ";"))))
+    (plcmp-collect-matches re 1 'match-string-no-properties)))
 
 ;;; methods
@@ -279 +369 @@
                                  "="
                                  (* space)
-                                 (group      ;2
+                                 (group      ;2 module-name
                                   (regexp ,using-module-re))))))
     (save-excursion
@@ -289 +379 @@
   (with-temp-buffer
     (insert str)
-    (loop initially (goto-char (point-min))
-          while (re-search-forward plcmp-perl-ident-re nil t)
-          collect (match-string-no-properties 0))))
+    (plcmp-collect-matches plcmp-perl-ident-re)))
 
 (defsubst plcmp--inspect-module-class-inspector (module-name)
@@ -311 +399 @@
 
 (defsubst plcmp-get-buffer-subs ()
-  (let ((re plcmp-sub-re))
-    (save-excursion
-      (loop initially (goto-char (point-min))
-            while (re-search-forward re nil t)
-            collect (match-string-no-properties 1)))))
+  (plcmp-collect-matches plcmp-sub-re 1 'match-string-no-properties))
 
 (defun plcmp--inspect-module-scrape (module-name)
@@ -338 +422 @@
   "alist, (module-name . (list of methods))")
 (defun plcmp-get-module-methods-alist (using-modules)
-  (dolist (module-name using-modules)
+  (dolist (module-name using-modules plcmp-module-methods-alist)
     (unless (assoc module-name plcmp-module-methods-alist)
       (add-to-list 'plcmp-module-methods-alist
-                   (plcmp--inspect-module module-name))))
-  plcmp-module-methods-alist)
+                   (plcmp--inspect-module module-name)))))
 
 
 ;; module-name -> source
 (defun plcmp--mk-module-source (module-name)
-  (plcmp-aif (assoc-default module-name plcmp-module-methods-alist)
+  (anything-aif (assoc-default module-name plcmp-module-methods-alist)
       `((name . ,(concat module-name " Methods"))
         (type . plcmp-completion)
@@ -366 +449 @@
   (rx (>= 4 (or (syntax word)
                 (syntax symbol)))))
-(defsubst* plcmp-get-buffer-dabbrevs (&optional (re plcmp-buffer-dabbrevs-re))
-  (save-excursion
-    (loop initially (goto-char (point-min))
-          while (re-search-forward re nil t)
-          collect (match-string-no-properties 0))))
+
+(defsubst* plcmp-get-buffer-dabbrevs ()
+  (plcmp-collect-matches plcmp-buffer-dabbrevs-re))
 
 ;;; current buffer words
+(defsubst* plcmp--check-face (face-names &optional (point (point)))
+  (let* ((face (get-text-property point 'face))
+         (faces (if (listp face) face (list face))))
+    (some (lambda (face-sym)
+            (memq face-sym faces))
+          face-names)))
+
 (defsubst* plcmp-get-face-words (&optional (faces '(font-lock-variable-name-face
                                                     font-lock-function-name-face)))
@@ -381 +469 @@
                                   (point-max))
             until (eobp)
-            do (progn (when (plcmp-check-face faces)
-                        (plcmp-aif (cperl-word-at-point)
+            do (progn (when (plcmp--check-face faces)
+                        (anything-aif (cperl-word-at-point)
                             (puthash it nil hash)))
                       (goto-char next-change)))
       (let ((ret))
-        (maphash (lambda (k v) (push k ret)) hash)
+        (maphash (lambda (k v) (push k ret)) hash) ; remove-dups
         ret))))
 
@@ -394 +482 @@
  (hash . (list of hashes))
  (functions . (list of functions)))")
-(add-hook 'plcmp-cleanup-hook (lambda () (setq plcmp-current-buffer-words-alist nil)))
+(add-hook 'plcmp--command-cleanup-hook (lambda () (setq plcmp-current-buffer-words-alist nil)))
 
 ;; (with-current-buffer "Plagger.pm"
@@ -412 +500 @@
                 (function . ,functions))))))
 
-
 (defun plcmp-get-current-buffer-variables ()
   (let ((alist (plcmp-get-current-buffer-words-alist)))
@@ -477 +564 @@
 
 
-
-(defsubst* plcmp-check-face (face-names &optional (point (point)))
-  (let* ((face (get-text-property point 'face))
-         (faces (if (listp face) face (list face))))
-    (some (lambda (face-sym)
-            (memq face-sym faces))
-          face-names)))
 
 ;;; man
@@ -506 +586 @@
 (defvar plcmp-doc-overlay nil "overlay")
 (defvar plcmp-doc-current-point nil)
-(add-hook 'plcmp-cleanup-hook
+(add-hook 'plcmp--command-cleanup-hook
           (lambda ()
             (setq plcmp-doc-current-point nil)))
+
 (defun plcmp-re-search-forward-fontify (regexp)
   (when (re-search-forward regexp nil t)
@@ -533 +614 @@
         plcmp-module-methods-alist (plcmp-get-module-methods-alist plcmp-using-modules)
         plcmp-obj-instance-of-module-maybe-alist (plcmp-get-obj-instance-of-module-maybe-alist plcmp-using-modules)
-        plcmp-initial-input (plcmp-get-initial-input)))
+        )
+  (multiple-value-setq
+      (plcmp-initial-input plcmp-real-initial-input) (plcmp-get-initial-real-input-list)))
 
 (defun plcmp-cleanup ()
   (when (overlayp plcmp-doc-overlay)
     (delete-overlay plcmp-doc-overlay))
-  (run-hooks 'plcmp-cleanup-hook))
+  (run-hooks 'plcmp--command-cleanup-hook))
 
 ;;;; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -564 +647 @@
 (defvar plcmp-type-man
   '(plcmp-doc
-    (action . (("Show with Woman" . woman)
-               ("Insert" . insert)
+    (action . (("Show man" .
+                (lambda (candidate)
+                  (plcmp-open-doc candidate 'man)))
+               ("Show man other window" .
+                (lambda (candidate)
+                  (plcmp-open-doc candidate 'man 'pop-to-buffer)))
+               ("Show man other window and go" .
+                (lambda (candidate)
+                  (plcmp-open-doc candidate 'man 'switch-to-buffer-other-window)))
+               ("Show man other frame and go" .
+                (lambda (candidate)
+                  (plcmp-open-doc candidate 'man 'switch-to-buffer-other-frame)))
+               ("Insert man name" . insert)
                ("Add command to kill-ring" . kill-new)))))
 
@@ -581 +675 @@
 
 ;;; perldoc
-(defun* plcmp-open-perldoc (word &optional (type 'module) (show-fn 'switch-to-buffer))
+(defun plcmp-get-man-buffer (topic)
+  "like `Man-getpage-in-background' but call process synchronously.
+return buffer or nil unless process return 0"
+  (require 'man)
+  (let* ((man-args topic)
+         (bufname (concat "*Man " man-args "*"))
+         (buffer  (get-buffer bufname)))
+    (if buffer
+        buffer
+      (require 'env)
+      (message "Invoking %s %s in the background" manual-program man-args)
+      (setq buffer (generate-new-buffer bufname))
+      (with-current-buffer buffer
+        (setq buffer-undo-list t)
+        (setq Man-original-frame (selected-frame))
+        (setq Man-arguments man-args))
+      (let ((process-environment (copy-sequence process-environment))
+            ;; The following is so Awk script gets \n intact
+            ;; But don't prevent decoding of the outside.
+            (coding-system-for-write 'raw-text-unix)
+            ;; We must decode the output by a coding system that the
+            ;; system's locale suggests in multibyte mode.
+            (coding-system-for-read
+             (if default-enable-multibyte-characters
+                 locale-coding-system 'raw-text-unix))
+            ;; Avoid possible error by using a directory that always exists.
+            (default-directory
+              (if (and (file-directory-p default-directory)
+                       (not (find-file-name-handler default-directory
+                                                    'file-directory-p)))
+                  default-directory
+                "/")))
+        ;; Prevent any attempt to use display terminal fanciness.
+        (setenv "TERM" "dumb")
+        ;; In Debian Woody, at least, we get overlong lines under X
+        ;; unless COLUMNS or MANWIDTH is set.  This isn't a problem on
+        ;; a tty.  man(1) says:
+        ;;        MANWIDTH
+        ;;               If $MANWIDTH is set, its value is used as the  line
+        ;;               length  for which manual pages should be formatted.
+        ;;               If it is not set, manual pages  will  be  formatted
+        ;;               with  a line length appropriate to the current ter-
+        ;;               minal (using an ioctl(2) if available, the value of
+        ;;               $COLUMNS,  or falling back to 80 characters if nei-
+        ;;               ther is available).
+        (if window-system
+            (unless (or (getenv "MANWIDTH") (getenv "COLUMNS"))
+              ;; This isn't strictly correct, since we don't know how
+              ;; the page will actually be displayed, but it seems
+              ;; reasonable.
+              (setenv "COLUMNS" (number-to-string
+                                 (cond
+                                  ((and (integerp Man-width) (> Man-width 0))
+                                   Man-width)
+                                  (Man-width (frame-width))
+                                  ((window-width)))))))
+        (setenv "GROFF_NO_SGR" "1")
+        (let ((exit-status
+               (call-process shell-file-name nil (list buffer nil) nil
+                             shell-command-switch
+                             (format (Man-build-man-command) man-args)))
+              (msg ""))
+          (when (and (numberp exit-status)
+                     (= exit-status 0))
+            (get-buffer bufname)))))))
+
+(defun* plcmp-open-doc (topic &optional (type 'module) (show-fn 'switch-to-buffer))
   (require 'man)
   (let ((manual-program (ecase type
                           (module "perldoc")
+                          (man manual-program)
                           (function "perldoc -f")
                           (variable "perldoc perlvar"))))
-    (flet ((Man-notify-when-ready (man-buffer)
-            (funcall show-fn man-buffer)))
-      (Man-getpage-in-background word))))
-
+    (let ((manbuf (plcmp-get-man-buffer topic)))
+      (when (bufferp manbuf)
+        (funcall show-fn manbuf)))))
 
 ;;; open module file
@@ -602 +762 @@
 
 (defun* plcmp-open-module-file (module-name &optional (show-buffer-fn 'switch-to-buffer))
-  (plcmp-aif (plcmp--find-module-file-no-select module-name)
+  (anything-aif (plcmp--find-module-file-no-select module-name)
       (funcall show-buffer-fn it)
     (message "can't find %s" module-name)))
@@ -639 +799 @@
     (init . (lambda ()
               (with-current-buffer (anything-candidate-buffer 'global)
-                (plcmp-insert-each-line plcmp-installed-modules))))
-    (candidates-in-buffer)))
+                (plcmp-insert-each-line (plcmp-get-installed-modules)))))
+    (candidates-in-buffer)
+    ))
 
 (defvar plcmp-anything-source-completion-buffer-dabbrevs
@@ -696 +857 @@
     plcmp-anything-source-completion-installed-modules))
 
-(defun plcmp-get-sources-completion-all ()
+(defun plcmp-get-sources-for-complete-all ()
   (append
    (plcmp-get-methods-completion-sources plcmp-using-modules)
@@ -702 +863 @@
 
 (define-plcmp-command complete-all ()
-  (anything (plcmp-get-sources-completion-all) plcmp-initial-input))
+  (anything (plcmp-get-sources-for-complete-all) plcmp-initial-input))
 
 
@@ -776 +937 @@
          (t
           'otherwise))))))
-
-(defun plcmp-get-sources-completion-smart ()
+;; TODO
+(defun plcmp-get-sources-for-smart-complete ()
   "return sources"
-  (let ((ctx (plcmp--get-context-symbol)))
-    (case ctx
-      (otherwise (plcmp-get-sources-completion-all)))))
+  (let ((ctx-sym (plcmp--get-context-symbol)))
+    (case ctx-sym
+      (otherwise (plcmp-get-sources-for-complete-all)))))
 
 ;;; document
@@ -793 +954 @@
   (anything '(plcmp-anything-source-menu)))
 
-(defun plcmp-cmd-clear-all-cache ()
+(defun plcmp-cmd-clear-all-caches ()
   (interactive)
-  (ignore-errors
-    (setq plcmp-module-methods-alist nil
-          plcmp-installed-modules nil)
-    (message "cleared all caches")))
+  (dolist (variable plcmp--cached-variables)
+    (set variable nil))
+  (message "cleared all caches"))
 
 (defun plcmp-cmd-show-environment ()
@@ -839 +999 @@
     (expectations
       (desc "define-plcmp-command macro expand")
-      (expect '(defun plcmp-cmd-test (arg1 arg2) (interactive) (cl-block-wrapper (catch (quote --cl-block-plcmp-cmd-test--) (plcmp-initialize-variables) (progn "test"))))
+      (expect '(defun plcmp-cmd-test (arg1 arg2)
+                 (interactive)
+                 (cl-block-wrapper
+                  (catch (quote --cl-block-plcmp-cmd-test--)
+                    (unwind-protect
+                        (progn (plcmp-initialize-variables)
+                               (progn "body"))
+                      (plcmp-cleanup)))))
         (macroexpand-all
          '(define-plcmp-command test (arg1 arg2)
-            "test")))
+            "body")))
       (desc "plcmp-get-face-words")
       (expect nil
@@ -879 +1046 @@
       (expect 'plcmp-anything-source-completion-builtin-variables
         (car (plcmp-re-sort-sources "variables" plcmp-completion-all-static-sources)))
+
+      (desc "plcmp--get-lib-path")
+      (expect "~/c/plagger/lib"
+        (stub plcmp-get-current-directory => "~/c/plagger/lib/Plagger/TT/Plagger/")
+        (plcmp--get-lib-path))
+      (expect "~/c/plagger/lib"
+        (stub plcmp-get-current-directory => "~/c/plagger/