Changeset 19304

Timestamp:

09/15/08 01:18:36 (4 months ago)

Author:

imakado

Message:

補完候補の並び順を賢く。*lib/というディレクトリがカレントディレクトリに含まれていたら補完候補収得の歳にPERL5LIBに一時的に追加する

Files:

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

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

@@ -37 +37 @@
 ;; TODO:
 ;; set-perl5lib
-
+;; open doc -> occur
 
 ;;;code:
@@ -46 +46 @@
 (require 'rx)
 
+
+
+
 (defgroup perl-completion nil
   ""
@@ -60 +63 @@
                                          (regexp ,plcmp-perl-ident-re)))))
 
-(defvar plcmp-perl-package-re "[a-zA-Z0-9:]+")
+(defvar plcmp-perl-package-re "[a-zA-Z:]+")
 
 (defvar plcmp-builtin-functions
@@ -122 +125 @@
 
 ;;; macros
+
+;; perl5 lib
+;; idea: http://svn.coderepos.org/share/lang/elisp/set-perl5lib/set-perl5lib.el
+;;       http://d.hatena.ne.jp/sun-basix/20080117/1200528765 (Japanese)
+; (buffer-file-name default-directory
+(defcustom plcmp-lib-directory-re "lib/"
+  "regexp, used in `plcmp--get-lib-path' to get library path.
+eg, when directory of buffer is \"~/someproject/lib/hoge.pm\" and this value is \"lib/\"
+set \"~/someproject/lib\" to PERL5LIB automatically during perl-completion's command invocation."
+    :group 'perl-completion)
+
+(defvar plcmp-additional-lib-directories nil
+  "list of string(directory),each directory set to PERL5LIB during perl-completion's command invocation.
+this variable is buffer local") ;buffer local
+(make-variable-buffer-local 'plcmp-additional-lib-directories)
+
+(defun plcmp-cmd-set-additional-lib-directory ()
+  "ask directory, then set directory to `plcmp-additional-lib-directories'"
+  (interactive)
+  (let* ((dir (read-directory-name "set to PERL5LIB(this buffer only): " nil nil t))
+         (dir (directory-file-name dir)))
+    (when (and (stringp dir)
+               (file-exists-p dir))
+      (add-to-list 'plcmp-additional-lib-directories dir)
+      (message "added %s to PERL5LIB" dir))))
+
+(defun plcmp--get-lib-path ()
+  "return string(additional library path)"
+  (let ((dir (plcmp-get-current-directory))
+        (lib-re (rx-to-string `(and (group
+                                     bol
+                                     (* not-newline)
+                                     ,plcmp-lib-directory-re)))))
+    (when (string-match lib-re dir)
+      (let ((lib-dir (match-string 1 dir)))
+        (and (stringp lib-dir)
+             (file-exists-p lib-dir)
+             (directory-file-name lib-dir))))))
+
+(defmacro plcmp-with-set-perl5-lib (&rest body)
+  "Set each path that value of `plcmp--get-lib-path' to PERL5LIB.
+then execute BODY"
+  `(let ((process-environment (copy-sequence process-environment)))
+     (require 'env)
+     (let ((additional-lib-list (append plcmp-additional-lib-directories
+                                        (when (plcmp--get-lib-path)
+                                          (list (plcmp--get-lib-path)))))
+           (old-perl5lib (or (getenv "PERL5LIB") "")))
+       (when additional-lib-list
+         (let* ((additional-lib-str (mapconcat 'identity additional-lib-list path-separator))
+                (current-perl5lib (concat additional-lib-str path-separator old-perl5lib)))
+           (when (and (stringp current-perl5lib)
+                      (not (equal "" current-perl5lib)))
+             (setenv "PERL5LIB" current-perl5lib)
+             (plcmp-log "plcmp-with-set-perl5-lib PERL5LIB: %s" current-perl5lib))
+           (progn
+             ,@body))))))
+
+
 (defmacro define-plcmp-command (command-name-with-no-prefix args &rest body)
   (let* ((prefix "plcmp-cmd-")
@@ -129 +191 @@
        (interactive)
        (unwind-protect
-           (progn (plcmp-initialize-variables)
-                  (progn
-                    ,@body))
+           (plcmp-with-set-perl5-lib
+            (progn (plcmp-initialize-variables)
+                   ,@body))
          (plcmp-cleanup)))))
 (put 'define-plcmp-command 'lisp-indent-function 'defun)
@@ -157 +219 @@
 
 (defsubst plcmp-notfound-p (s)
-  (string-match "^Can't locate [^ \t]+ in" s))
+  (anything-aif (string-match "^Can't locate [^ \t]+ in" s)
+      (prog1 it
+        (plcmp-log "module notfound errmsg: %s" s))))
 
 (defsubst plcmp-tramp-p ()
   (when (and (featurep 'tramp)
              (fboundp 'tramp-tramp-file-p))
-    (tramp-tramp-file-p (plcmp-get-current-directory))))
+    (let* ((dir (plcmp-get-current-directory))
+           (tramp? (tramp-tramp-file-p dir)))
+      (when tramp?
+        (prog1 tramp?
+          (plcmp-log "plcmp-tramp-p return non-nil: %s" dir))))))
 
 (defsubst plcmp-insert-each-line (los)
@@ -192 +260 @@
               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
+    (error (plcmp-log "Error: plcmp-re-sort-sources\nregexps: %s\nsources: %s"
+                      regexps
+                      sources)
+            sources)))
+
+(defsubst* plcmp-collect-matches
     (re &optional (count 0) (match-string-fn 'match-string)
         (point-min (point-min)) (point-max (point-max)))
@@ -202 +272 @@
           while (re-search-forward re point-max t)
           collect (funcall match-string-fn count))))
+
+(defun plcmp-get-occur-fn ()
+  "return `occur-by-moccur if installed color-moccur.el otherwise return `occur"
+  (if (require 'color-moccur nil t)
+      'occur-by-moccur
+    'occur))
+
 
 ;;; log
@@ -210 +287 @@
 (defun plcmp-log (&rest messages)
   (ignore-errors
-    (let* ((str (or (ignore-errors (apply 'format messages))
-                    (prin1-to-string messages)))
-           (strn (concat str "\n")))
-      (when plcmp-debug
+    (when plcmp-debug
+      (require 'pp)
+      (let* ((str (or (ignore-errors (apply 'format messages))
+                      (pp-to-string messages)))
+             (strn (concat str "\n")))
         (with-current-buffer (plcmp-log-buf)
           (goto-char (point-max))
-          (insert strn)))
-      str)))
+          (insert strn))
+        str))))
 (defun plcmp-message (&rest args)
   (when plcmp-debug
-    (apply 'message args)))
+    (prog1 (apply 'message args)
+      (apply 'plcmp-log args))))
 
 
@@ -233 +312 @@
              (end (condition-case e
                       (cond
-                       ((some (lambda (s) (string-equal s preceding-string)) '("$" "@" "&" "&"))
+                       ((some (lambda (s) (string-equal s preceding-string)) '("$" "@" "%" "&"))
                         (backward-char)
                         (point))
@@ -247 +326 @@
                            " "
                          "")))))
-        (values initial-input real-initial-input)))))
+        (prog1 (values initial-input real-initial-input)
+          (plcmp-log "plcmp-get-initial-real-input-list:\ninitial-input: %s\nreal-initial-input: %s"
+                     initial-input
+                     real-initial-input))))))
 
 ;;; installed modules
@@ -281 +363 @@
       (unless (zerop (buffer-size))
         (setq plcmp-installed-modules (plcmp-collect-matches plcmp-perl-package-re))
-        (plcmp-message "cached installed modules %s" plcmp-installed-modules)))))
+        (message "finished getting installed modules asynchronously.")
+        (plcmp-log "cached installed modules %s" plcmp-installed-modules)))))
 
 (defun plcmp--installed-modules-asynchronously ()
@@ -301 +384 @@
     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 "")
@@ -345 +400 @@
       (goto-char (point-min))
       (when (re-search-forward re nil t)
-        (setq plcmp-current-package-name
-              (match-string-no-properties 1))))))
+        (match-string-no-properties 1)))))
 
 (defvar plcmp-using-modules nil)
@@ -401 +455 @@
   (plcmp-collect-matches plcmp-sub-re 1 'match-string-no-properties))
 
+(defun plcmp-get-module-file-path (module-name)
+  (let* ((path (shell-command-to-string (concat "perldoc -l " (shell-quote-argument module-name))))
+         (path (plcmp-trim path)))
+    (and (file-exists-p path)
+         path)))
+
 (defun plcmp--inspect-module-scrape (module-name)
   (when (and (stringp module-name)
              (plcmp-module-p module-name))
-    (let* ((path (shell-command-to-string (concat "perldoc -l "
-                                                  module-name)))
-           (path (plcmp-trim path)))
+    (let* ((path (plcmp-get-module-file-path module-name)))
       (when (and (stringp path)
                  (file-exists-p path)
@@ -415 +473 @@
 
 (defsubst plcmp--inspect-module (module-name)
-  (or (plcmp--inspect-module-class-inspector module-name)
-      (plcmp--inspect-module-scrape module-name)))
+  (prog1 (or (plcmp--inspect-module-class-inspector module-name)
+             (plcmp--inspect-module-scrape module-name))
+    (message "getting methods %s ..." module-name)))
 
 
@@ -429 +488 @@
 
 ;; module-name -> source
+(defvar plcmp--mk-module-source-name " Methods")
+
 (defun plcmp--mk-module-source (module-name)
   (anything-aif (assoc-default module-name plcmp-module-methods-alist)
-      `((name . ,(concat module-name " Methods"))
-        (type . plcmp-completion)
+      `((name . ,(concat module-name plcmp--mk-module-source-name))
+        (type . plcmp-completion-method)
         (init . (lambda ()
                   (with-current-buffer (anything-candidate-buffer 'global)
@@ -482 +543 @@
  (hash . (list of hashes))
  (functions . (list of functions)))")
-(add-hook 'plcmp--command-cleanup-hook (lambda () (setq plcmp-current-buffer-words-alist nil)))
-
-;; (with-current-buffer "Plagger.pm"
-;;   (plcmp-get-face-words '(font-lock-variable-name-face)))
+(add-hook 'plcmp--command-cleanup-hook
+          (lambda ()
+            (setq plcmp-current-buffer-words-alist nil)))
 
 
@@ -502 +562 @@
 (defun plcmp-get-current-buffer-variables ()
   (let ((alist (plcmp-get-current-buffer-words-alist)))
-    (assoc-default 'variable alist 'eq)))
-
-(defvar plcmp-anything-source-current-buffer-variables
+    (prog1 (assoc-default 'variable alist 'eq)
+      (plcmp-log "getting current buffer variables"))))
+
+(defvar plcmp-anything-source-completion-current-buffer-variables
   `((name . "buffer variables")
     (type . plcmp-completion)
@@ -515 +576 @@
 (defun plcmp-get-current-buffer-arrays ()
   (let ((alist (plcmp-get-current-buffer-words-alist)))
-    (assoc-default 'array plcmp-current-buffer-words-alist 'eq)))
-
-(defvar plcmp-anything-source-current-buffer-arrays
+    (prog1 (assoc-default 'array alist 'eq)
+      (plcmp-log "getting current buffer arrays"))))
+
+(defvar plcmp-anything-source-completion-current-buffer-arrays
   `((name . "buffer arrays")
     (type . plcmp-completion)
@@ -528 +590 @@
 (defun plcmp-get-current-buffer-hashes ()
   (let ((alist (plcmp-get-current-buffer-words-alist)))
-    (assoc-default 'hash alist 'eq)))
-
-(defvar plcmp-anything-source-current-buffer-hashes
+    (prog1 (assoc-default 'hash alist 'eq)
+      (plcmp-log "getting current buffer hashes"))))
+
+(defvar plcmp-anything-source-completion-current-buffer-hashes
   `((name . "buffer hashes")
     (type . plcmp-completion)
@@ -541 +604 @@
 (defun plcmp-get-current-buffer-functions ()
   (let ((alist (plcmp-get-current-buffer-words-alist)))
-    (assoc-default 'function alist 'eq)))
-
-(defvar plcmp-anything-source-current-buffer-functions
+    (prog1 (assoc-default 'function alist 'eq)
+      (plcmp-log "getting current buffer functions"))))
+
+(defvar plcmp-anything-source-completion-current-buffer-functions
   `((name . "buffer functions")
     (type . plcmp-completion)
@@ -555 +619 @@
 ;;; other buffer words
 (defvar plcmp-perl-buffer-re "\\.p[lm]$")
+(defvar plcmp-other-perl-buffers-words-faces
+  '(font-lock-function-name-face
+    font-lock-variable-name-face
+    font-lock-keyword-face
+    font-lock-builtin-face
+    font-lock-type-face
+    cperl-array-face
+    cperl-hash-face))
+
 (defun plcmp-get-other-perl-buffers-words ()
   (let ((perl-buffers (remove-if-not (lambda (buf)
                                        (string-match plcmp-perl-buffer-re (buffer-name buf)))
                                      (buffer-list))))
-    (loop for buffer in perl-buffers
-          nconc (with-current-buffer buffer
-                  (plcmp-get-face-words)))))
-
+    (prog1 (loop for buffer in perl-buffers
+                 nconc (with-current-buffer buffer
+                         (plcmp-get-face-words plcmp-other-perl-buffers-words-faces)))
+      (plcmp-log "length of other perl-buffers: %s" (length perl-buffers)))))
 
 
@@ -626 +699 @@
 ;;;; Anything
 ;;;; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+(defun plcmp--anything-get-current-source-name ()
+  "Return the source name for the current selection."
+  (declare (special source))
+  ;; The name `anything-get-current-source' should be used in init function etc.
+  (if (and (boundp 'anything-source-name) (stringp anything-source-name))
+      anything-source-name
+    (with-current-buffer (anything-buffer-get)
+      ;; This goto-char shouldn't be necessary, but point is moved to
+      ;; point-min somewhere else which shouldn't happen.
+      (goto-char (overlay-start anything-selection-overlay))
+      (let* ((header-pos (anything-get-previous-header-pos)))
+        (save-excursion
+          (assert header-pos)
+          (goto-char header-pos)
+          (prog1 (buffer-substring-no-properties
+                  (line-beginning-position) (line-end-position))
+            (plcmp-log "plcmp-anything-get-current-source-name: %s"
+                       (buffer-substring-no-properties
+                        (line-beginning-position) (line-end-position)))))))))
+
+(defun plcmp-get-current-module-name ()
+  (let* ((module (plcmp--anything-get-current-source-name)))
+    (when (string-match
+           (rx-to-string `(and
+                           bol
+                           (group
+                            (regexp ,plcmp-perl-package-re))
+                           ,plcmp--mk-module-source-name))
+           module)
+      (match-string 1 module))))
+
 (defvar plcmp-type-completion
     '(plcmp-completion
       (action . (("Insert" . plcmp-insert)
-                 ("Open module file" . plcmp-open-module-file)
+;;                  ("Open module file" . plcmp-open-module-file)
+;;                  ("Open module file other window" .
+;;                   (lambda (candidate)
+;;                     (plcmp-open-module-file candidate
+;;                                             'switch-to-buffer-other-window)))
+;;                  ("Open module file other frame" .
+;;                   (lambda (candidate)
+;;                     (plcmp-open-module-file candidate
+;;                                             'switch-to-buffer-other-frame)))
+                 
+                 ("Add to kill-ring" . kill-new)
+                 ("Insert source name" .
+                  (lambda (candidate)
+                    (let ((name (plcmp-anything-get-current-source-name)))
+                      (and (stringp name)
+                           (insert name)))))
+                 ))))
+(add-to-list 'anything-type-attributes plcmp-type-completion)
+
+(defvar plcmp-type-completion-method
+    '(plcmp-completion-method
+      (action . (("Insert" . plcmp-insert)
+                 ("Open module file" .
+                  (lambda (method)
+                    (let ((module (plcmp-get-current-module-name)))
+                      (plcmp-open-module-file module))))
                  ("Open module file other window" .
-                  (lambda (candidate)
-                    (plcmp-open-module-file candidate
-                                            'switch-to-buffer-other-window)))
+                  (lambda (method)
+                    (let ((module-name (plcmp-get-current-module-name)))
+                      (plcmp-open-module-file module-name 'pop-to-buffer))))
                  ("Open module file other frame" .
                   (lambda (candidate)
-                    (plcmp-open-module-file candidate
-                                            'switch-to-buffer-other-frame)))
-                 ("Add command to kill-ring" . kill-new)
-                 ;;                 ("Perldoc" . (lambda (candidate)
-                 ;;                                (plcmp-perldoc plcmp-data candidate)))
-                 ;;                 ("Perldoc -m" . (lambda (candidate)
-                 ;;                                   (plcmp-perldoc-m plcmp-data candidate)))
+                    (let ((module-name (plcmp-get-current-module-name)))
+                      (plcmp-open-module-file module-name
+                                              'switch-to-buffer-other-frame))))
+                 ("Add to kill-ring" . kill-new)
+                 ("Insert source name" .
+                  (lambda (candidate)
+                    (let ((name (plcmp-anything-get-current-source-name)))
+                      (and (stringp name)
+                           (insert name)))))
                  ))))
+(add-to-list 'anything-type-attributes plcmp-type-completion-method)
 
 (defvar plcmp-type-man
@@ -659 +792 @@
                 (lambda (candidate)
                   (plcmp-open-doc candidate 'man 'switch-to-buffer-other-frame)))
+               ("occur man buffer" .
+                (lambda (candidate)
+                  (when (plcmp-open-doc candidate 'man)
+                    (call-interactively (plcmp-get-occur-fn) candidate))))
                ("Insert man name" . insert)
-               ("Add command to kill-ring" . kill-new)))))
+               ("Add man name to kill-ring" . kill-new)))))
 
 (defvar plcmp-type-perldoc
   '(plcmp-perldoc
     (action . ())))
-
-;; append plcmp-* types to `anything-type-attributes'
-(add-to-list 'anything-type-attributes plcmp-type-completion)
 (add-to-list 'anything-type-attributes plcmp-type-man)
 
@@ -675 +809 @@
 
 ;;; perldoc
-(defun plcmp-get-man-buffer (topic)
+(defun* plcmp-get-man-buffer (topic &optional (type 'module))
   "like `Man-getpage-in-background' but call process synchronously.
 return buffer or nil unless process return 0"
   (require 'man)
-  (let* ((man-args topic)
+  (let* ((manual-program (ecase type
+                           (module "perldoc")
+                           (man manual-program)
+                           (function "perldoc -f")
+                           (variable "perldoc perlvar")))
+         (man-args topic)
          (bufname (concat "*Man " man-args "*"))
          (buffer  (get-buffer bufname)))
@@ -743 +882 @@
 (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"))))
-    (let ((manbuf (plcmp-get-man-buffer topic)))
-      (when (bufferp manbuf)
-        (funcall show-fn manbuf)))))
+  (let ((manbuf (plcmp-get-man-buffer topic type)))
+    (when (and (bufferp manbuf)
+               (functionp show-fn))
+      (funcall show-fn manbuf))))
+
 
 ;;; open module file
 (defun plcmp--find-module-file-no-select (module-name)
   (when (plcmp-module-p module-name)
-    (let* ((path (shell-command-to-string (concat "perldoc -l " module-name)))
-           (path (expand-file-name (plcmp-trim path))))
+    (let* ((path (plcmp-get-module-file-path module-name))
+           (path (expand-file-name path)))
       (when (and (file-exists-p path)
                  (file-readable-p path))
@@ -807 +943 @@
     (type . plcmp-completion)
     (init . (lambda ()
-              (let ((words (plcmp-get-buffer-dabbrevs)))
+              (let* ((words (plcmp-get-buffer-dabbrevs))
+                     (words (delete plcmp-real-initial-input words)))
                 (with-current-buffer (anything-candidate-buffer 'global)
                   (plcmp-insert-each-line words)))))
+    (requires-pattern . 4)
     (candidates-in-buffer)))
 
@@ -818 +956 @@
               (with-current-buffer (anything-candidate-buffer 'global)
                 (plcmp-insert-each-line (plcmp-get-other-perl-buffers-words)))))
+    (requires-pattern . 3)
     (candidates-in-buffer)))
+
 
 ;; man, perldoc
@@ -850 +990 @@
 ;;; complete-all
 (defvar plcmp-completion-all-static-sources
-  '(plcmp-anything-source-completion-buffer-dabbrevs
+  '(
+    plcmp-anything-source-completion-buffer-dabbrevs
+    plcmp-anything-source-completion-using-modules
+    plcmp-anything-source-completion-current-buffer-variables
+    plcmp-anything-source-completion-current-buffer-arrays
+    plcmp-anything-source-completion-current-buffer-hashes
+    plcmp-anything-source-completion-current-buffer-functions
+    plcmp-anything-source-completion-builtin-variables
+    plcmp-anything-source-completion-builtin-functions    
     plcmp-anything-source-completion-other-perl-buffers-words
-    plcmp-anything-source-completion-builtin-variables
-    plcmp-anything-source-completion-builtin-functions
-    plcmp-anything-source-completion-using-modules
-    plcmp-anything-source-completion-installed-modules))
+    plcmp-anything-source-completion-installed-modules
+    ))
 
 (defun plcmp-get-sources-for-complete-all ()
@@ -901 +1047 @@
                        (save-excursion (or (ignore-errors (backward-sexp)
                                                           (point))
-                                           (point))))))
-        (cond
-         ;; package
-         ;; $self->`!!'
-         ;; __PACKAGE__->`!!'
-         ((and (plcmp-method-p)
-               (string-match (rx bol
-                                 (or "$self"
-                                     "__PACKAGE__")
-                                 eol)
-                             obj-str))
-          'package)
-         ;; method
-         ;; Foo->`!!'
-         ((plcmp-method-p)
-          'method)
-         ;; variable
-         ;; $foo`!!'
-         ((string-equal "$" (plcmp-preceding-string 1))
-          'variable)
-         ;; array
-         ((string-equal "@" (plcmp-preceding-string 1))
-          'array)
-         ;; hash
-         ((string-equal "%" (plcmp-preceding-string 1))
-          'array)
-         ;; function
-         ((string-equal "&" (plcmp-preceding-string 1))
-          'function)
-         ;; installed-module
-         ;; use `!!'
-         ((string-match (rx bol (* space) "use" (+ space))
-                        (buffer-substring (point-at-bol) (point)))