root/lang/elisp/perl-completion/branch/1.0/perl-completion.el @ 19503

Revision 19503, 63.8 kB (checked in by imakado, 5 years ago)

initialinput収得部分変更。初回起動時の補完候補収得の際にもPERL5LIBを自動で追加するように。他のバッファから補完候補を収得する部分の実装。smart-completeのアルゴリズム変更

Line 
1;;;  -*- coding: utf-8; mode: emacs-lisp; -*-
2;;; perl-completion.el
3
4;; Author: Kenji.Imakado <ken.imakaado@gmail.com>
5;; Keywords: perl
6
7;; This file is free software; you can redistribute it and/or modify
8;; it under the terms of the GNU General Public License as published by
9;; the Free Software Foundation; either version 2, or (at your option)
10;; any later version.
11
12;; This file is distributed in the hope that it will be useful,
13;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15;; GNU General Public License for more details.
16
17;; You should have received a copy of the GNU General Public License
18;; along with GNU Emacs; see the file COPYING.  If not, write to the
19;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
20;; Boston, MA 02110-1301, USA.
21
22;; Prefix: plcmp-
23
24;;; Commentary:
25;; Tested on Emacs 22
26
27;; to customize
28;; M-x customize-group RET perl-completion RET
29
30
31;; TODO:
32;; set-perl5lib
33;; open doc -> occur
34;; when remote(tramp) set-perl5lib
35;; plcmp-cmd-show-environment
36
37;;;code:
38(require 'cl)
39(require 'anything) ; perl-completion.el uses `anything-aif' macro.
40(require 'cperl-mode)
41(require 'dabbrev)
42(require 'rx)
43
44
45
46
47(defgroup perl-completion nil
48  ""
49  :group 'perl-completion)
50
51;;; variables
52(defvar plcmp-version 1.0)
53
54(defvar plcmp-perl-ident-re "[a-zA-Z_][a-zA-Z_0-9]*")
55
56(defvar plcmp-sub-re (rx-to-string `(and "sub"
57                                        (+ space)
58                                        (group
59                                         (regexp ,plcmp-perl-ident-re)))))
60
61(defvar plcmp-perl-package-re "[a-zA-Z:]+")
62
63(defvar plcmp-builtin-functions
64  '("abs" "exec" "glob" "order" "seek" "symlink" "accept" "exists" "gmtime"
65    "our" "seekdir" "syscall" "alarm" "exit" "goto" "pack" "select" "sysopen"
66    "atan" "exp" "grep" "package" "semctl" "sysread" "bind" "fcntl" "hex"
67    "pipe" "semget" "sysseek" "binmode" "fileno" "import" "pop" "semop"
68    "system" "bless" "flags" "index" "pos" "send" "syswrite" "caller" "flock"
69    "int" "precision" "setgrent" "tell" "chdir" "fork" "ioctl" "print" "sethostent"
70    "telldir" "chmod" "format" "join" "printf" "setnetent" "tie" "chomp" "formline"
71    "keys" "prototype" "setpgrp" "tied" "chop" "getc" "kill" "push" "setpriority"
72    "time" "chown" "getgrent" "last" "q" "setprotoent" "times" "chr" "getgrgid"
73    "lc" "qq" "setpwent" "tr" "chroot" "getgrnam" "lcfirst" "qr" "setservent"
74    "truncate" "close" "gethostbyaddr" "length" "quotemeta" "setsockopt" "uc"
75    "closedir" "gethostbyname" "link" "qw" "shift" "ucfirst" "connect" "gethostent"
76    "listen" "qx" "shmctl" "umask" "continue" "getlogin" "local" "rand" "shmget"
77    "undef" "cos" "getnetbyaddr" "localtime" "read" "shmread" "unlink" "crypt"
78    "getnetbyname" "lock" "readdir" "shmwrite" "unpack" "dbmclose" "getnetent"
79    "log" "readline" "shutdown" "unshift" "dbmopen" "getpeername" "lstat" "readlink"
80    "sin" "untie" "defined" "getpgrp" "m" "readpipe" "size" "use" "delete" "getppid"
81    "map" "recv" "sleep" "utime" "die" "getpriority" "mkdir" "redo" "socket" "values"
82    "do" "getprotobyname" "msgctl" "ref" "socketpair" "vec" "dump" "getprotobynumber"
83    "msgget" "rename" "sort" "vector" "each" "getprotoent" "msgrcv" "require" "splice"
84    "wait" "endgrent" "getpwent" "msgsnd" "reset" "split" "waitpid" "endhostent"
85    "getpwnam" "my" "return" "sprintf" "wantarray" "endnetent" "getpwuid" "next"
86    "reverse" "sqrt" "warn" "endprotoent" "getservbyname" "no" "rewinddir" "srand"
87    "write" "endpwent" "getservbyport" "oct" "rindex" "stat" "y" "endservent" "getservent"
88    "open" "rmdir" "study" "eof" "getsockname" "opendir" "s" "sub" "eval" "getsockopt"
89    "ord" "scalar" "substr"))
90
91(defvar plcmp-builtin-variables
92  '("$SIG{expr}" "%SIG" "$ENV{expr}" "%ENV" "%INC" "@_" "@INC" "@F" "ARGVOUT"
93    "@ARGV" "$ARGV" "ARGV" "$^X" "$EXECUTABLE_NAME" "${^WARNING_BITS}" "$^W"
94    "$WARNING" "$^V" "$PERL_VERSION" "${^UTF8LOCALE}" "${^UNICODE}" "${^TAINT}"
95    "$^T" "$BASETIME" "$^S" "$EXCEPTIONS_BEING_CAUGHT" "$^R"
96    "$LAST_REGEXP_CODE_RESULT" "$^P" "$PERLDB" "${^OPEN}" "$^O" "$OSNAME" "$^M" "$^I" "$INPLACE_EDIT"
97    "%^H" "$^H" "$^F" "$SYSTEM_FD_MAX" "$^D" "$DEBUGGING" "$^C" "$COMPILING" "$]"
98    "$[" "$0" "$PROGRAM_NAME" "$)" "$EGID" "$EFFECTIVE_GROUP_ID" "$(" "$GID" "$REAL_GROUP_ID"
99    "$>" "$EUID" "$EFFECTIVE_USER_ID" "$<" "$UID" "$REAL_USER_ID" "$$" "$PID" "$PROCESS_ID"
100    "$@" "$EVAL_ERROR" "$^E" "$EXTENDED_OS_ERROR" "%!" "$!" "$ERRNO" "$OS_ERROR" "${^ENCODING}"
101    "$?" "$CHILD_ERROR" "$^A" "$ACCUMULATOR" "$^L" "$FORMAT_FORMFEED" "IO::Handle->format_formfeed" "$:"
102    "$FORMAT_LINE_BREAK_CHARACTERS" "IO::Handle->format_line_break_characters" "$^"
103    "$FORMAT_TOP_NAME" "HANDLE->format_top_name(EXPR)" "$~"
104    "$FORMAT_NAME" "HANDLE->format_name(EXPR)" "@-" "@LAST_MATCH_START"
105    "$-" "$FORMAT_LINES_LEFT" "HANDLE->format_lines_left(EXPR)" "$="
106    "$FORMAT_LINES_PER_PAGE" "HANDLE->format_lines_per_page(EXPR)" "$%"
107    "$FORMAT_PAGE_NUMBER" "HANDLE->format_page_number(EXPR)" "$#" "$;"
108    "$SUBSEP" "$SUBSCRIPT_SEPARATOR" "$\"" "$LIST_SEPARATOR" "$\\" "$ORS"
109    "$OUTPUT_RECORD_SEPARATOR" "IO::Handle->output_record_separator" "$," "$OFS"
110    "$OUTPUT_FIELD_SEPARATOR" "IO::Handle->output_field_separator" "$|"
111    "$OUTPUT_AUTOFLUSH" "HANDLE->autoflush(EXPR)" "$/" "$RS"
112    "$INPUT_RECORD_SEPARATOR" "IO::Handle->input_record_separator(EXPR)" "$."
113    "$NR" "$INPUT_LINE_NUMBER" "HANDLE->input_line_number(EXPR)" "$*" "@+"
114    "@LAST_MATCH_END" "$^N" "$+" "$LAST_PAREN_MATCH" "$'" "$POSTMATCH" "$`"
115    "$PREMATCH" "$&" "$MATCH" "$<digits>" "$b" "$a" "$_" "$ARG"))
116
117(defvar plcmp--command-cleanup-hook nil "hook run when completion command finished")
118
119(defvar plcmp--cached-variables nil "list of cached variable. each variable is cleared by `plcmp-cmd-clear-all-caches'")
120
121
122;;; macros
123
124;; perl5 lib
125;; idea: http://svn.coderepos.org/share/lang/elisp/set-perl5lib/set-perl5lib.el
126;;       http://d.hatena.ne.jp/sun-basix/20080117/1200528765 (Japanese)
127; (buffer-file-name default-directory
128(defcustom plcmp-lib-directory-re "lib/"
129  "regexp, used in `plcmp--get-lib-path' to get library path.
130eg, when directory of buffer is \"~/someproject/lib/hoge.pm\" and this value is \"lib/\"
131set \"~/someproject/lib\" to PERL5LIB automatically during perl-completion's command invocation."
132    :group 'perl-completion)
133
134(defvar plcmp-additional-lib-directories nil
135  "list of string(directory),each directory set to PERL5LIB during perl-completion's command invocation.
136this variable is buffer local") ;buffer local
137(make-variable-buffer-local 'plcmp-additional-lib-directories)
138
139
140
141(defun plcmp--get-lib-path ()
142  "return string(additional library path)"
143  (let ((dir (plcmp-get-current-directory))
144        (lib-re (rx-to-string `(and (group
145                                     bol
146                                     (* not-newline)
147                                     ,plcmp-lib-directory-re)))))
148    (when (string-match lib-re dir)
149      (let ((lib-dir (match-string 1 dir)))
150        (and (stringp lib-dir)
151             (file-exists-p lib-dir)
152             (directory-file-name lib-dir))))))
153
154(defmacro plcmp-with-set-perl5-lib (&rest body)
155  "Set each path that value of `plcmp--get-lib-path' to PERL5LIB.
156then execute BODY"
157  `(let ((process-environment (copy-sequence process-environment)))
158     (require 'env)
159     (let ((additional-lib-list (append plcmp-additional-lib-directories
160                                        (when (plcmp--get-lib-path)
161                                          (list (plcmp--get-lib-path)))))
162           (old-perl5lib (or (getenv "PERL5LIB") "")))
163       (when additional-lib-list
164         (let* ((additional-lib-str (mapconcat 'identity additional-lib-list path-separator))
165                (current-perl5lib (concat additional-lib-str path-separator old-perl5lib)))
166           (when (and (stringp current-perl5lib)
167                      (not (equal "" current-perl5lib)))
168             (setenv "PERL5LIB" current-perl5lib)
169             (plcmp-log "plcmp-with-set-perl5-lib PERL5LIB: %s" current-perl5lib)))))
170     (progn
171       ,@body)))
172
173
174(defmacro define-plcmp-command (command-name-with-no-prefix args &rest body)
175  (let* ((prefix "plcmp-cmd-")
176         (command-str (symbol-name command-name-with-no-prefix))
177         (command-name (concat prefix command-str)))
178    `(defun* ,(intern command-name) ,args
179       (interactive)
180       (unwind-protect
181           (plcmp-with-set-perl5-lib
182            (progn (plcmp-initialize-variables)
183                   ,@body))
184         (plcmp-cleanup)))))
185(put 'define-plcmp-command 'lisp-indent-function 'defun)
186(def-edebug-spec define-plcmp-command defun*)
187
188(defmacro plcmp-ignore-errors (&rest body)
189  `(condition-case e (progn ,@body)
190     (error (plcmp-log "Error plcmp-ignore-errors :  %s" (error-message-string e)))))
191(def-edebug-spec plcmp-ignore-errors ignore-errors)
192
193;;; Util functions
194(defsubst plcmp-trim (s)
195  "strip space and newline"
196  (replace-regexp-in-string
197   "[ \t\n]*$" "" (replace-regexp-in-string "^[ \t\n]*" "" s)))
198
199(defsubst plcmp-bit-regexp-p (s)
200  (string-match "^[/:$@&%(),.?<>+!|^*';\"\\]+$" s))
201
202(defsubst plcmp-module-p (s)
203  (string-match "^[a-zA-Z:]+$" s))
204
205(defsubst plcmp-perl-identifier-p (s)
206  (string-match (concat "^" plcmp-perl-ident-re "$") s))
207
208(defsubst plcmp-notfound-p (s)
209  (anything-aif (string-match "^Can't locate [^ \t]+ in" s)
210      (prog1 it
211        (plcmp-log "module notfound errmsg: %s" s))))
212
213(defsubst plcmp-tramp-p ()
214  (when (and (featurep 'tramp)
215             (fboundp 'tramp-tramp-file-p))
216    (let* ((dir (plcmp-get-current-directory))
217           (tramp? (tramp-tramp-file-p dir)))
218      (when tramp?
219        (prog1 tramp?
220          (plcmp-log "plcmp-tramp-p return non-nil: %s" dir))))))
221
222(defsubst plcmp-insert-each-line (los)
223  (insert (mapconcat 'identity los "\n")))
224
225(defun plcmp-get-current-directory ()
226  (file-name-directory
227   (expand-file-name
228    (or (buffer-file-name)
229        default-directory))))
230
231;; TODO: need test.
232(defsubst plcmp--re-match-sources1 (regexps source)
233  (when source
234    (let ((source (if (listp source) source (symbol-value source))))
235      (some (lambda (re)
236              (string-match re (assoc-default 'name source 'eq)))
237            regexps))))
238
239(defun plcmp-re-sort-sources (regexps sources &optional reverse)
240  (condition-case e
241      (let* ((regexps (if (stringp regexps) (list regexps) regexps))
242             (match-sources)
243             (unmatch-sources)
244             (sorted-sources (loop for source in sources
245              if (plcmp--re-match-sources1 regexps source)
246              collect source into match-sources
247              else
248              collect source into unmatch-sources
249              finally return (if reverse
250                                 (nconc unmatch-sources match-sources)
251                               (nconc match-sources unmatch-sources)))))
252        (prog1 sorted-sources
253          (plcmp-log "plcmp-re-sort-sources: %s" sorted-sources)))
254    (error (plcmp-log "Error: plcmp-re-sort-sources\nregexps: %s\nsources: %s"
255                      regexps
256                      sources)
257           sources)))
258
259(defsubst* plcmp-collect-matches
260    (re &optional (count 0) (match-string-fn 'match-string)
261        (point-min (point-min)) (point-max (point-max)))
262  (save-excursion
263    (loop initially (goto-char point-min)
264          while (re-search-forward re point-max t)
265          collect (funcall match-string-fn count))))
266
267(defun plcmp-get-occur-fn ()
268  "return `occur-by-moccur if installed color-moccur.el otherwise return `occur"
269  (if (require 'color-moccur nil t)
270      'occur-by-moccur
271    'occur))
272
273
274;;; log
275(defvar plcmp-debug nil)
276(defvar plcmp-log-buf-name "*plcmp debug*")
277(defun plcmp-log-buf ()
278  (get-buffer-create plcmp-log-buf-name))
279(defun plcmp-log (&rest messages)
280  (ignore-errors
281    (when plcmp-debug
282      (require 'pp)
283      (let* ((str (or (ignore-errors (apply 'format messages))
284                      (pp-to-string (car messages))))
285             (strn (concat str "\n")))
286        (with-current-buffer (plcmp-log-buf)
287          (goto-char (point-max))
288          (insert strn))
289        str))))
290(defun plcmp-message (&rest args)
291  (when plcmp-debug
292    (prog1 (apply 'message args)
293      (apply 'plcmp-log args))))
294
295
296(defvar plcmp-initial-input "")
297(defvar plcmp-real-initial-input "real initial-input if required `anything-match-plugin' initial-input is not real initial-input")
298
299(defun plcmp--fullname ()
300  (save-excursion
301    (let ((start (point)))
302      (skip-chars-backward "a-zA-Z0-9_")
303      (let ((str (plcmp-preceding-string 2)))
304        (when (string-equal str "::")
305          (buffer-substring-no-properties start (point)))))))
306         
307
308(defun plcmp-get-initial-real-input-list ()
309  "return list (initial-input real-initial-input)"
310  (save-excursion
311    (let* ((start (point))
312           (real-initial-input
313            (cond
314             ((plcmp--fullname))
315             (t
316              (skip-syntax-backward "w_")
317              (let* ((preceding-string (char-to-string (preceding-char)))
318                     (end (condition-case e
319                              (cond
320                               ((some (lambda (s) (string-equal s preceding-string)) '("$" "@" "%" "&"))
321                                (backward-char)
322                                (point))
323                               (t
324                                (point)))
325                            (error (point)))))
326                (buffer-substring-no-properties start end)))))
327           (initial-input
328            (regexp-quote
329             (concat real-initial-input
330                     (if (and (featurep 'anything-match-plugin)
331                              (not (string-equal real-initial-input "")))
332                         " "
333                       "")))))
334      (prog1 (values initial-input real-initial-input)
335        (plcmp-log "plcmp-get-initial-real-input-list:\ninitial-input: %s\nreal-initial-input: %s"
336                   initial-input
337                   real-initial-input)))))
338
339
340;;; installed modules
341(defvar plcmp-installed-modules nil)
342(add-to-list 'plcmp--cached-variables 'plcmp-installed-modules)
343
344(defun plcmp-get-installed-modules ()
345  (unless (plcmp-tramp-p)
346    (or plcmp-installed-modules
347        (setq plcmp-installed-modules
348              (plcmp--installed-modules-synchronously)))))
349
350(defun plcmp--installed-modules-synchronously ()
351  (message "fetching installed modules...")
352  (let* ((modules-str (shell-command-to-string
353                       (concat
354                        "find `perl -e 'pop @INC; print join(q{ }, @INC);'`"
355                        " -name '*.pm' -type f "
356                        "| xargs egrep -h -o 'package [a-zA-Z0-9:]+;' "
357                        "| perl -nle 's/package\s+(.+);/$1/; print' "
358                        "| sort "
359                        "| uniq "
360                        )))
361         (modules (split-string modules-str "\n")))
362    (message "done")
363    (remove-if (lambda (module)
364                 (string-match "No such file or directory$" module))
365               modules)))
366
367(defvar plcmp-installed-modules-buffer-name " *perl-completion installed modules*")
368(defun plcmp--installed-modules-set-cache (process event)
369  (when (string-equal "finished\n" event)
370    (with-current-buffer plcmp-installed-modules-buffer-name
371      (unless (zerop (buffer-size))
372        (setq plcmp-installed-modules (plcmp-collect-matches plcmp-perl-package-re))
373        (message "finished getting installed modules asynchronously.")
374        (plcmp-log "cached installed modules %s" plcmp-installed-modules)))))
375
376(defun plcmp--installed-modules-asynchronously ()
377  "start process, set sentinel, return process."
378  (message "fetching installed modules...")
379  (let* ((command "find")
380         (args (concat "`perl -e 'pop @INC; print join(q{ }, @INC);'`"
381                       " -name '*.pm' -type f "
382                       "| xargs grep -E -h -o 'package [a-zA-Z0-9:]+;' "
383                       "| perl -nle 's/package\s+(.+);/$1/; print' "
384                       "| sort "
385                       "| uniq "))
386         (proc (start-process-shell-command "installed perl modules"
387                                            plcmp-installed-modules-buffer-name
388                                            command
389                                            args)))
390    (set-process-sentinel proc 'plcmp--installed-modules-set-cache)
391    ;; return process
392    proc))
393
394
395;;; current package
396(defvar plcmp-current-package-name "")
397(defun plcmp-get-current-package-name ()
398  "nil or string"
399  (let ((re (rx-to-string `(and bol
400                                (* space)
401                                "package"
402                                (* space)
403                                (group
404                                 (regexp ,plcmp-perl-package-re))
405                                (* not-newline)
406                                ";"))))
407    (save-excursion
408      (goto-char (point-min))
409      (when (re-search-forward re nil t)
410        (match-string-no-properties 1)))))
411
412(defvar plcmp-using-modules nil)
413(defun plcmp-get-using-modules ()
414  (let ((re (rx-to-string `(and bol
415                                (* space)
416                                "use"
417                                (+ space)
418                                (group  ;1 package
419                                 (regexp ,plcmp-perl-package-re))
420                                (* not-newline)
421                                ";"))))
422    (plcmp-collect-matches re 1 'match-string-no-properties)))
423
424;;; methods
425(defvar plcmp-obj-instance-of-module-maybe-alist nil)
426(defun plcmp-get-obj-instance-of-module-maybe-alist (using-modules)
427  (let* ((using-module-re (regexp-opt using-modules))
428         (re (rx-to-string `(and (group "$" ;1
429                                  (regexp ,plcmp-perl-ident-re))
430                                 (* space)
431                                 "="
432                                 (* space)
433                                 (group      ;2 module-name
434                                  (regexp ,using-module-re))))))
435    (save-excursion
436      (loop initially (goto-char (point-min))
437            while (re-search-forward re nil t)
438            collect `(,(match-string-no-properties 1) . ,(match-string-no-properties 2))))))
439
440(defsubst plcmp--make-los (str)
441  (with-temp-buffer
442    (insert str)
443    (plcmp-collect-matches plcmp-perl-ident-re)))
444
445(defsubst plcmp--inspect-module-class-inspector (module-name)
446  "Class::Inspectorを使用してモジュールのメソッド調べる。
447モジュール名に使用でき-る文字以外が含まれていた場合はnilを返す
448return alist (module-name . list of methods)"
449  (when (plcmp-module-p module-name)
450    (let ((modules-str
451           (shell-command-to-string
452            (concat "perl -MClass::Inspector -e'use "
453                    module-name
454                    "; print join \"\n\"=>@{Class::Inspector->methods("
455                    module-name
456                    ")} '"))))
457      (when (and (not (plcmp-notfound-p modules-str))
458                 (stringp modules-str))
459        (let ((modules (plcmp--make-los modules-str)))
460          `(,module-name . ,modules))))))
461
462(defsubst plcmp-get-buffer-subs ()
463  (plcmp-collect-matches plcmp-sub-re 1 'match-string-no-properties))
464
465(defun plcmp-get-module-file-path (module-name)
466  (let* ((path (shell-command-to-string (concat "perldoc -l " (shell-quote-argument module-name))))
467         (path (plcmp-trim path)))
468    (and (stringp path)
469         (file-exists-p path)
470         path)))
471
472(defun plcmp--inspect-module-scrape (module-name)
473  (when (and (stringp module-name)
474             (plcmp-module-p module-name))
475    (let* ((path (plcmp-get-module-file-path module-name)))
476      (when (and (stringp path)
477                 (file-exists-p path)
478                 (file-readable-p path))
479        (with-temp-buffer
480          (insert-file-contents path)
481          (plcmp-get-buffer-subs))))))
482
483(defsubst plcmp--inspect-module (module-name)
484  (prog1 (or (plcmp--inspect-module-class-inspector module-name)
485             (plcmp--inspect-module-scrape module-name))
486    (message "getting methods %s ..." module-name)))
487
488
489(defvar plcmp-module-methods-alist nil
490  "alist, (module-name . (list of methods))")
491(defun plcmp-get-module-methods-alist (using-modules)
492  (dolist (module-name using-modules plcmp-module-methods-alist)
493    (unless (assoc module-name plcmp-module-methods-alist)
494      (add-to-list 'plcmp-module-methods-alist
495                   (plcmp--inspect-module module-name)))))
496
497
498;; module-name -> source
499(defvar plcmp--mk-module-source-name " Methods")
500
501(defun plcmp--mk-module-source (module-name)
502  (anything-aif (assoc-default module-name plcmp-module-methods-alist)
503      `((name . ,(concat module-name plcmp--mk-module-source-name))
504        (action . (("Insert" . plcmp-insert)
505                   ("Show doc" .
506                    (lambda (candidate)
507                      (let* ((module (plcmp-get-current-module-name))
508                             (buf (plcmp-get-man-buffer module 'module)))
509                        (save-selected-window
510                          (pop-to-buffer buf)))))
511                   ("Show doc and go" .
512                    (lambda (candidate)
513                      (let* ((module (plcmp-get-current-module-name))
514                             (buf (plcmp-get-man-buffer module 'module)))
515                        (pop-to-buffer buf))))
516                   ("Open module file" .
517                    (lambda (method)
518                      (let ((module (plcmp-get-current-module-name)))
519                        (plcmp-open-module-file module))))
520                   ("Open module file other window" .
521                    (lambda (method)
522                      (let ((module-name (plcmp-get-current-module-name)))
523                        (plcmp-open-module-file module-name 'pop-to-buffer))))
524                   ("Open module file other frame" .
525                  (lambda (candidate)
526                    (let ((module-name (plcmp-get-current-module-name)))
527                      (plcmp-open-module-file module-name
528                                              'switch-to-buffer-other-frame))))
529                   ("Add to kill-ring" . kill-new)
530                   ("Insert source name" .
531                    (lambda (candidate)
532                      (let ((name (plcmp-anything-get-current-source-name)))
533                        (and (stringp name)
534                             (insert name)))))
535                   ))
536        (init . (lambda ()
537                  (with-current-buffer (anything-candidate-buffer 'global)
538                    (plcmp-insert-each-line ',it))))
539        (candidates-in-buffer))))
540
541
542;; plcmp-using-modules -> sources
543(defun plcmp-get-methods-completion-sources (using-modules)
544  (loop for module-name in using-modules
545        collect (plcmp--mk-module-source module-name)))
546
547
548;;; dabbrev
549(defvar plcmp-buffer-dabbrevs-re
550  (rx (>= 4 (or (syntax word)
551                (syntax symbol)))))
552
553(defsubst* plcmp-get-buffer-dabbrevs ()
554  (plcmp-collect-matches plcmp-buffer-dabbrevs-re))
555
556;;; current buffer words
557(defsubst* plcmp--check-face (face-names &optional (point (point)))
558  (let* ((face (get-text-property point 'face))
559         (faces (if (listp face) face (list face))))
560    (some (lambda (face-sym)
561            (memq face-sym faces))
562          face-names)))
563
564(defsubst* plcmp-get-face-words (&optional (faces '(font-lock-variable-name-face
565                                                    font-lock-function-name-face)))
566  (let ((hash (make-hash-table :test 'equal)))
567    (save-excursion
568      (loop initially (goto-char (point-min))
569            for next-change = (or (next-property-change (point) (current-buffer))
570                                  (point-max))
571            until (eobp)
572            do (progn (when (plcmp--check-face faces)
573                        (anything-aif (cperl-word-at-point)
574                            (puthash it nil hash)))
575                      (goto-char next-change)))
576      (let ((ret))
577        (maphash (lambda (k v) (push k ret)) hash) ; remove-dups
578        ret))))
579
580(defvar plcmp-current-buffer-words-alist nil
581  "alist, ((variable . (list of variables))
582 (array . (list of arrays))
583 (hash . (list of hashes))
584 (functions . (list of functions)))")
585(add-hook 'plcmp--command-cleanup-hook
586          (lambda ()
587            (setq plcmp-current-buffer-words-alist nil)))
588
589
590(defun plcmp-get-current-buffer-words-alist ()
591  (or plcmp-current-buffer-words-alist
592      (let ((variables (plcmp-get-face-words '(font-lock-variable-name-face)))
593            (arrays (plcmp-get-face-words '(cperl-array-face)))
594            (hashes (plcmp-get-face-words '(cperl-hash-face)))
595            (functions (plcmp-get-buffer-subs)))
596        (setq plcmp-current-buffer-words-alist
597              `((variable . ,variables)
598                (array . ,arrays)
599                (hash . ,hashes)
600                (function . ,functions))))))
601
602(defun plcmp-get-current-buffer-variables ()
603  (let ((alist (plcmp-get-current-buffer-words-alist)))
604    (prog1 (assoc-default 'variable alist 'eq)
605      (plcmp-log "getting current buffer variables"))))
606
607(defvar plcmp-anything-source-completion-current-buffer-variables
608  `((name . "buffer variables")
609    (type . plcmp-completion)
610    (init . (lambda ()
611              (let ((words (plcmp-get-current-buffer-variables)))
612                (with-current-buffer (anything-candidate-buffer 'global)
613                  (plcmp-insert-each-line words)))))
614    (candidates-in-buffer)))
615
616(defun plcmp-get-current-buffer-arrays ()
617  (let ((alist (plcmp-get-current-buffer-words-alist)))
618    (prog1 (assoc-default 'array alist 'eq)
619      (plcmp-log "getting current buffer arrays"))))
620
621(defvar plcmp-anything-source-completion-current-buffer-arrays
622  `((name . "buffer arrays")
623    (type . plcmp-completion)
624    (init . (lambda ()
625              (let ((words (plcmp-get-current-buffer-arrays)))
626                (with-current-buffer (anything-candidate-buffer 'global)
627                  (plcmp-insert-each-line words)))))
628    (candidates-in-buffer)))
629
630(defun plcmp-get-current-buffer-hashes ()
631  (let ((alist (plcmp-get-current-buffer-words-alist)))
632    (prog1 (assoc-default 'hash alist 'eq)
633      (plcmp-log "getting current buffer hashes"))))
634
635(defvar plcmp-anything-source-completion-current-buffer-hashes
636  `((name . "buffer hashes")
637    (type . plcmp-completion)
638    (init . (lambda ()
639              (let ((words (plcmp-get-current-buffer-hashes)))
640                (with-current-buffer (anything-candidate-buffer 'global)
641                  (plcmp-insert-each-line words)))))
642    (candidates-in-buffer)))
643
644(defun plcmp-get-current-buffer-functions ()
645  (let ((alist (plcmp-get-current-buffer-words-alist)))
646    (prog1 (assoc-default 'function alist 'eq)
647      (plcmp-log "getting current buffer functions"))))
648
649(defvar plcmp-anything-source-completion-current-buffer-functions
650  `((name . "buffer functions")
651    (type . plcmp-completion)
652    (init . (lambda ()
653              (let ((words (plcmp-get-current-buffer-functions)))
654                (with-current-buffer (anything-candidate-buffer 'global)
655                  (plcmp-insert-each-line words)))))
656    (candidates-in-buffer)))
657
658
659;;; other buffer words
660(defvar plcmp-perl-buffer-re "\\.p[lm]$")
661(defvar plcmp-other-perl-buffer-limit-number 30)
662(defvar plcmp-other-perl-buffers-words-faces
663  '(font-lock-function-name-face
664    font-lock-variable-name-face
665    font-lock-keyword-face
666    font-lock-builtin-face
667    font-lock-type-face
668    cperl-array-face
669    cperl-hash-face))
670
671(defun plcmp-get-other-perl-buffers-words ()
672  (let* ((perl-buffers (remove-if-not (lambda (buf)
673                                       (string-match plcmp-perl-buffer-re (buffer-name buf)))
674                                     (buffer-list)))
675         (perl-buffers (subseq perl-buffers 0 plcmp-other-perl-buffer-limit-number)))
676    (prog1 (loop for buffer in perl-buffers
677                 when (bufferp buffer)
678                 nconc (with-current-buffer buffer
679                         (plcmp-get-face-words plcmp-other-perl-buffers-words-faces)))
680      (plcmp-log "length of other perl-buffers: %s" (length perl-buffers)))))
681
682
683(defun plcmp--mk-other-perl-buffer-source (source-name faces buffer-name)
684  `((name . ,(concat source-name " *" buffer-name "*"))
685    (action . (("Insert" . plcmp-insert)))
686    (init . (lambda ()
687              (let ((words (with-current-buffer (get-buffer ,buffer-name)
688                             (plcmp-get-face-words ',faces))))
689                (with-current-buffer (anything-candidate-buffer 'global)
690                  (plcmp-insert-each-line words)))))
691    (candidates-in-buffer)))
692
693(defun plcmp--sources-other-perl-buffers (source-name faces)
694  (let* ((perl-buffers (remove-if-not (lambda (buf)
695                                        (string-match plcmp-perl-buffer-re (buffer-name buf)))
696                                      (buffer-list)))
697         (perl-buffers (subseq perl-buffers 0 plcmp-other-perl-buffer-limit-number))
698         (sources (loop for buffer in perl-buffers
699                        when (bufferp buffer)
700                        collect (with-current-buffer buffer
701                                  (plcmp--mk-other-perl-buffer-source
702                                   source-name
703                                   faces
704                                   (buffer-name buffer))))))
705    (prog1 sources
706      (plcmp-log "plcmp--sources-other-perl-buffers:")
707      (plcmp-log sources))))
708   
709(defun plcmp-get-sources-other-perl-buffers-variable ()
710  (plcmp--sources-other-perl-buffers "variables" '(font-lock-variable-name-face)))
711
712(defun plcmp-get-sources-other-perl-buffers-hashes ()
713  (plcmp--sources-other-perl-buffers "hashes" '(cperl-hash-face)))
714
715(defun plcmp-get-sources-other-perl-buffers-arrays ()
716  (plcmp--sources-other-perl-buffers "arrays" '(cperl-array-face)))
717
718(defun plcmp-get-sources-other-perl-buffers-functions ()
719  (plcmp--sources-other-perl-buffers "functions" '(font-lock-function-name-face)))
720
721;;; man
722(defvar plcmp-man-pages
723  (condition-case nil
724      (let ((pages
725             (progn
726               (require 'woman)
727               (woman-file-name "")
728               (mapcar 'car
729                       woman-topic-all-completions))))
730        (remove-if-not (lambda (s)
731                         (or (member s plcmp-installed-modules)
732                             (string-match "perl" s)))
733                       pages))
734    (error nil)))
735
736
737;;;; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
738;;;; Document
739;;;; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
740(defvar plcmp-doc-overlay nil "overlay")
741(defvar plcmp-doc-current-point nil)
742(add-hook 'plcmp--command-cleanup-hook
743          (lambda ()
744            (setq plcmp-doc-current-point nil)))
745
746(defun plcmp-re-search-forward-fontify (regexp)
747  (when (re-search-forward regexp nil t)
748    (let ((beg (match-beginning 1))
749          (end (match-end 1)))
750      ;; remember point
751      (setq plcmp-doc-current-point (point))
752     
753      (when (and beg end)
754        (if (overlayp plcmp-doc-overlay)
755            (move-overlay plcmp-doc-overlay beg end (current-buffer))
756          (setq plcmp-doc-overlay (make-overlay beg end)))
757        (overlay-put plcmp-doc-overlay 'face 'highlight)))))
758
759
760
761;;;; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
762;;;; Initialize, Cleanup
763;;;; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
764(defun plcmp-initialize-variables ()
765  (setq plcmp-installed-modules (plcmp-get-installed-modules)
766        plcmp-current-package-name (plcmp-get-current-package-name)
767        plcmp-using-modules (plcmp-get-using-modules)
768        plcmp-module-methods-alist (plcmp-get-module-methods-alist plcmp-using-modules)
769        plcmp-obj-instance-of-module-maybe-alist (plcmp-get-obj-instance-of-module-maybe-alist plcmp-using-modules)
770        )
771  (multiple-value-setq
772      (plcmp-initial-input plcmp-real-initial-input) (plcmp-get-initial-real-input-list)))
773
774(defun plcmp-cleanup ()
775  (when (overlayp plcmp-doc-overlay)
776    (delete-overlay plcmp-doc-overlay))
777  (run-hooks 'plcmp--command-cleanup-hook))
778
779;;;; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
780;;;; Anything
781;;;; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
782
783(defun plcmp--anything-get-current-source-name ()
784  "Return the source name for the current selection."
785  (declare (special source))
786  ;; The name `anything-get-current-source' should be used in init function etc.
787  (if (and (boundp 'anything-source-name) (stringp anything-source-name))
788      anything-source-name
789    (with-current-buffer (anything-buffer-get)
790      ;; This goto-char shouldn't be necessary, but point is moved to
791      ;; point-min somewhere else which shouldn't happen.
792      (goto-char (overlay-start anything-selection-overlay))
793      (let* ((header-pos (anything-get-previous-header-pos)))
794        (save-excursion
795          (assert header-pos)
796          (goto-char header-pos)
797          (prog1 (buffer-substring-no-properties
798                  (line-beginning-position) (line-end-position))
799            (plcmp-log "plcmp-anything-get-current-source-name: %s"
800                       (buffer-substring-no-properties
801                        (line-beginning-position) (line-end-position)))))))))
802
803(defun plcmp-get-current-module-name ()
804  (let* ((module (plcmp--anything-get-current-source-name)))
805    (when (string-match
806           (rx-to-string `(and
807                           bol
808                           (group
809                            (regexp ,plcmp-perl-package-re))
810                           ,plcmp--mk-module-source-name))
811           module)
812      (match-string 1 module))))
813
814;;;TODO
815(defun plcmp-completion-get-man-buffer (candidate)
816  "return manpage buffer ,called in completion source action"
817  (let* ((name (plcmp--anything-get-current-source-name))
818         (ret (cond
819               ((string-equal name "builtin functions")
820                (plcmp-get-man-buffer candidate 'function))
821               ((or (string-equal name "using modules")
822                    (string-equal name "installed modules"))
823                (plcmp-get-man-buffer candidate))
824               ((string-equal name "builtin variables")
825                (plcmp-get-man-buffer "" 'variables))
826               ((string-match (concat plcmp--mk-module-source-name "$")
827                              name)
828                (plcmp-get-current-module-name)))))
829    (prog1 ret
830      (plcmp-log "plcmp-completion-get-man-buffer candidate: %s return: %s"
831                 candidate
832                 ret))))
833
834
835(defvar plcmp-type-completion
836    '(plcmp-completion
837      (action . (("Insert" . plcmp-insert)
838                 ("Show man" .
839                  (lambda (candidate)
840                    (anything-aif (plcmp-completion-get-man-buffer candidate)
841                        (switch-to-buffer it))))
842;;                  ("Open module file" . plcmp-open-module-file)
843;;                  ("Open module file other window" .
844;;                   (lambda (candidate)
845;;                     (plcmp-open-module-file candidate
846;;                                             'switch-to-buffer-other-window)))
847;;                  ("Open module file other frame" .
848;;                   (lambda (candidate)
849;;                     (plcmp-open-module-file candidate
850;;                                             'switch-to-buffer-other-frame)))
851                 
852                 ("Add to kill-ring" . kill-new)
853                 ("Insert source name" .
854                  (lambda (candidate)
855                    (let ((name (plcmp-anything-get-current-source-name)))
856                      (and (stringp name)
857                           (insert name)))))
858                 ))))
859(add-to-list 'anything-type-attributes plcmp-type-completion)
860
861(defvar plcmp-type-completion-method
862    '(plcmp-completion-method
863      (action . (("Insert" . plcmp-insert)
864                 ("Open module file" .
865                  (lambda (method)
866                    (let ((module (plcmp-get-current-module-name)))
867                      (plcmp-open-module-file module))))
868                 ("Open module file other window" .
869                  (lambda (method)
870                    (let ((module-name (plcmp-get-current-module-name)))
871                      (plcmp-open-module-file module-name 'pop-to-buffer))))
872                 ("Open module file other frame" .
873                  (lambda (candidate)
874                    (let ((module-name (plcmp-get-current-module-name)))
875                      (plcmp-open-module-file module-name
876                                              'switch-to-buffer-other-frame))))
877                 ("Add to kill-ring" . kill-new)
878                 ("Insert source name" .
879                  (lambda (candidate)
880                    (let ((name (plcmp-anything-get-current-source-name)))
881                      (and (stringp name)
882                           (insert name)))))
883                 ))))
884(add-to-list 'anything-type-attributes plcmp-type-completion-method)
885
886(defvar plcmp-type-man
887  '(plcmp-doc
888    (action . (("Show man" .
889                (lambda (candidate)
890                  (plcmp-open-doc candidate 'man)))
891               ("Show man other window" .
892                (lambda (candidate)
893                  (plcmp-open-doc candidate 'man 'pop-to-buffer)))
894               ("Show man other window and go" .
895                (lambda (candidate)
896                  (plcmp-open-doc candidate 'man 'switch-to-buffer-other-window)))
897               ("Show man other frame and go" .
898                (lambda (candidate)
899                  (plcmp-open-doc candidate 'man 'switch-to-buffer-other-frame)))
900               ("occur man buffer" .
901                (lambda (candidate)
902                  (when (plcmp-open-doc candidate 'man)
903                    (call-interactively (plcmp-get-occur-fn)
904                                        (regexp-quote candidate)))))
905               ("Insert man name" . insert)
906               ("Add man name to kill-ring" . kill-new)))))
907
908(defvar plcmp-type-perldoc
909  '(plcmp-perldoc
910    (action . ())))
911(add-to-list 'anything-type-attributes plcmp-type-man)
912
913(defun plcmp-insert (candidate)
914  (delete-backward-char (length plcmp-real-initial-input))
915  (insert candidate))
916
917;;; perldoc
918(defun* plcmp-get-man-buffer (topic &optional (type 'module))
919  "like `Man-getpage-in-background' but call process synchronously.
920return buffer or nil unless process return 0"
921  (require 'man)
922  (let* ((manual-program (ecase type
923                           (module "perldoc")
924                           (man manual-program)
925                           (function "perldoc -f")
926                           (variable "perldoc perlvar")))
927         (command (if (eq type 'variable)
928                      manual-program
929                    (concat manual-program " " topic)))
930         (bufname (concat "*perldoc " topic "*"))
931         (buffer  (get-buffer-create bufname)))
932    (require 'env)
933    (let ((process-environment (copy-sequence process-environment))
934            ;; The following is so Awk script gets \n intact
935            ;; But don't prevent decoding of the outside.
936            (coding-system-for-write 'raw-text-unix)
937            ;; We must decode the output by a coding system that the
938            ;; system's locale suggests in multibyte mode.
939            (coding-system-for-read
940             (if default-enable-multibyte-characters
941                 locale-coding-system 'raw-text-unix))
942            ;; Avoid possible error by using a directory that always exists.
943            (default-directory
944              (if (and (file-directory-p default-directory)
945                       (not (find-file-name-handler default-directory
946                                                    'file-directory-p)))
947                  default-directory
948                "/")))
949        ;; Prevent any attempt to use display terminal fanciness.
950        (setenv "TERM" "dumb")
951        (save-window-excursion (shell-command command bufname))
952        (get-buffer bufname))))
953
954(defun* plcmp-open-doc (topic &optional (type 'module) (show-fn 'switch-to-buffer))
955  (require 'man)
956  (let ((manbuf (plcmp-get-man-buffer topic type)))
957    (when (and (bufferp manbuf)
958               (functionp show-fn))
959      (funcall show-fn manbuf))))
960
961
962;;; open module file
963(defun plcmp--find-module-file-no-select (module-name)
964  (when (plcmp-module-p module-name)
965    (let* ((path (plcmp-get-module-file-path module-name))
966           (path (expand-file-name path)))
967      (when (and (file-exists-p path)
968                 (file-readable-p path))
969        (find-file-noselect path)))))
970
971(defun* plcmp-open-module-file (module-name &optional (show-buffer-fn 'switch-to-buffer))
972  (anything-aif (plcmp--find-module-file-no-select module-name)
973      (funcall show-buffer-fn it)
974    (message "can't find %s" module-name)))
975
976;;; sources
977;; completion
978(defvar plcmp-anything-source-completion-using-modules
979  `((name . "using modules")
980    (action . (("Insert" . plcmp-insert)
981               ("Show doc" .
982                (lambda (candidate)
983                  (let ((buf (plcmp-get-man-buffer candidate 'module)))
984                    (save-selected-window
985                      (pop-to-buffer buf)))))
986               ("Show doc and go" .
987                (lambda (candidate)
988                  (let ((buf (plcmp-get-man-buffer candidate 'module)))
989                    (pop-to-buffer buf))))
990               ("occur" .
991                (lambda (candidate)
992                  (let ((buf (plcmp-get-man-buffer candidate 'module)))
993                    (switch-to-buffer buf)
994                    (call-interactively (plcmp-get-occur-fn)))))
995               ("Add to kill-ring" . kill-new)))
996    (init . (lambda ()
997              (with-current-buffer (anything-candidate-buffer 'global)
998                (plcmp-insert-each-line plcmp-using-modules))))
999    (candidates-in-buffer)))
1000
1001(defvar plcmp-anything-source-completion-builtin-functions
1002  `((name . "builtin functions")
1003    (action . (("Insert" . plcmp-insert)
1004               ("Show doc" .
1005                (lambda (candidate)
1006                  (let ((buf (plcmp-get-man-buffer candidate 'function)))
1007                    (save-selected-window
1008                      (pop-to-buffer buf)))))
1009               ("Show doc and go" .
1010                (lambda (candidate)
1011                  (let ((buf (plcmp-get-man-buffer candidate 'function)))
1012                    (switch-to-buffer-other-window buf))))
1013               ("occur" .
1014                (lambda (candidate)
1015                  (let ((buf (plcmp-get-man-buffer candidate 'function)))
1016                    (switch-to-buffer buf)
1017                    (funcall (plcmp-get-occur-fn)
1018                             (regexp-quote candidate)
1019                             nil))))
1020               ("Add to kill-ring" . kill-new)))
1021    (init . (lambda ()
1022              (with-current-buffer (anything-candidate-buffer 'global)
1023                (plcmp-insert-each-line plcmp-builtin-functions))))
1024    (candidates-in-buffer)))
1025
1026(defvar plcmp-anything-source-completion-builtin-variables
1027  `((name . "builtin variables")
1028    (action . (("Insert" . plcmp-insert)
1029               ("Show doc" .
1030                (lambda (candidate)
1031                  (let ((buf (plcmp-get-man-buffer candidate 'variable))
1032                        (re (rx-to-string `(and bol (= 4 space)
1033                                                (group (eval ,candidate))
1034                                                (syntax whitespace)))))
1035                    (with-current-buffer buf
1036                      (re-search-forward re nil t))
1037                    (save-selected-window
1038                      (pop-to-buffer buf)))))
1039               ("Show doc and go" .
1040                (lambda (candidate)
1041                  (let ((buf (plcmp-get-man-buffer candidate 'variable))
1042                        (re (rx-to-string `(and bol (= 4 space)
1043                                                (group (eval ,candidate))
1044                                                (syntax whitespace)))))
1045                    (switch-to-buffer-other-window buf)
1046                    (re-search-forward re nil t))))
1047               ("occur" .
1048                (lambda (candidate)
1049                  (let ((buf (plcmp-get-man-buffer candidate 'variable)))
1050                    (switch-to-buffer buf)
1051                    (funcall (plcmp-get-occur-fn)
1052                             (regexp-quote candidate)
1053                             nil))))
1054               ("Add to kill-ring" . kill-new)))
1055    (init . (lambda ()
1056              (with-current-buffer (anything-candidate-buffer 'global)
1057                (plcmp-insert-each-line plcmp-builtin-variables))))
1058    (candidates-in-buffer)
1059    (search . ((lambda (re arg1 arg2)
1060                 (re-search-forward (regexp-quote re) nil t))))))
1061
1062(defvar plcmp-anything-source-completion-installed-modules
1063  `((name . "installed modules")
1064    (action . (("Insert" . plcmp-insert)
1065               ("Show doc" .
1066                (lambda (candidate)
1067                  (let ((buf (plcmp-get-man-buffer candidate 'module)))
1068                    (save-selected-window
1069                      (pop-to-buffer buf)))))
1070               ("Show doc and go" .
1071                (lambda (candidate)
1072                  (let ((buf (plcmp-get-man-buffer candidate 'module)))
1073                    (pop-to-buffer buf))))
1074               ("occur" .
1075                (lambda (candidate)
1076                  (let ((buf (plcmp-get-man-buffer candidate 'module)))
1077                    (switch-to-buffer buf)
1078                    (call-interactively (plcmp-get-occur-fn)))))
1079               ("Add to kill-ring" . kill-new)))
1080    (init . (lambda ()
1081              (with-current-buffer (anything-candidate-buffer 'global)
1082                (plcmp-insert-each-line (plcmp-get-installed-modules)))))
1083    (candidates-in-buffer)
1084    ))
1085
1086(defvar plcmp-anything-source-completion-buffer-dabbrevs
1087  `((name . "buffer dabbrevs")
1088    (action . (("Insert" . plcmp-insert)
1089               ("occur" .
1090                (lambda (candidate)
1091                  (funcall (plcmp-get-occur-fn)
1092                           (regexp-quote candidate)
1093                           nil)))
1094               ("Add to kill-ring" . kill-new)))
1095    (init . (lambda ()
1096              (let* ((words (plcmp-get-buffer-dabbrevs))
1097                     (words (delete plcmp-real-initial-input words)))
1098                (with-current-buffer (anything-candidate-buffer 'global)
1099                  (plcmp-insert-each-line words)))))
1100    (requires-pattern . 4)
1101    (candidates-in-buffer)))
1102
1103(defvar plcmp-anything-source-completion-other-perl-buffers-words
1104  `((name . "other buffer keywords")
1105    (action . (("Insert" . plcmp-insert)))
1106    (init . (lambda ()
1107              (with-current-buffer (anything-candidate-buffer 'global)
1108                (plcmp-insert-each-line (plcmp-get-other-perl-buffers-words)))))
1109    (requires-pattern . 3)
1110    (candidates-in-buffer)))
1111
1112
1113;; man, perldoc
1114(defvar plcmp-anything-source-doc-man-pages
1115  '((name . "perl man pages")
1116    (action . (("Show man" . woman)))
1117    (init . (lambda ()
1118              (with-current-buffer (anything-candidate-buffer 'global)
1119                (plcmp-insert-each-line plcmp-man-pages))))
1120    (candidates-in-buffer)))
1121
1122(defvar plcmp-anything-source-doc-using-modules
1123  '((name . "using modules")
1124    (action . (("Show doc" .
1125                (lambda (candidate)
1126                  (let ((buf (plcmp-get-man-buffer candidate 'module)))
1127                    (save-selected-window
1128                      (pop-to-buffer buf)))))
1129               ("Show doc and go" .
1130                (lambda (candidate)
1131                  (let ((buf (plcmp-get-man-buffer candidate 'module)))
1132                    (switch-to-buffer buf))))
1133               ("occur doc buffer" .
1134                (lambda (candidate)
1135                  (let ((buf (plcmp-get-man-buffer candidate 'module)))
1136                    (switch-to-buffer buf)
1137                    (call-interactively (plcmp-get-occur-fn)
1138                                        (regexp-quote candidate)))))
1139               ("Add to kill-ring" . kill-new)))
1140    (init . (lambda ()
1141              (with-current-buffer (anything-candidate-buffer 'global)
1142                (plcmp-insert-each-line plcmp-using-modules))))
1143    (candidates-in-buffer)))
1144
1145(defvar plcmp-anything-source-doc-installed-modules
1146  '((name . "installed modules")
1147    (action . (("Show doc" .
1148                (lambda (candidate)
1149                  (let ((buf (plcmp-get-man-buffer candidate 'module)))
1150                    (save-selected-window
1151                      (pop-to-buffer buf)))))
1152               ("Show doc and go" .
1153                (lambda (candidate)
1154                  (let ((buf (plcmp-get-man-buffer candidate 'module)))
1155                    (switch-to-buffer buf))))
1156               ("occur doc buffer" .
1157                (lambda (candidate)
1158                  (let ((buf (plcmp-get-man-buffer candidate 'module)))
1159                    (switch-to-buffer buf)
1160                    (call-interactively (plcmp-get-occur-fn)))))
1161               ("Add to kill-ring" . kill-new)))
1162    (init . (lambda ()
1163              (with-current-buffer (anything-candidate-buffer 'global)
1164                (plcmp-insert-each-line plcmp-installed-modules))))
1165    (candidates-in-buffer)))
1166
1167
1168;; menu
1169(defvar plcmp-anything-source-menu
1170  `((name . "perl-completion menu")
1171    (type . command)
1172;;     (init . (lambda ()
1173;;               (with-current-buffer (anything-candidate-buffer 'global)
1174;;                 (let ((commands (loop for sym being the symbols
1175;;                                       for s = (symbol-name sym)
1176;;                                       when (string-match (concat "^" "plcmp-cmd-") s)
1177;;                                       collect s)))
1178;;                   (plcmp-insert-each-line commands)))))
1179    (candidates .  (lambda ()
1180                     (with-current-buffer anything-current-buffer
1181                       (loop for sym being the symbols
1182                             for s = (symbol-name sym)
1183                             when (string-match (concat "^" "plcmp-cmd-") s)
1184                             collect `(,(concat (substitute-command-keys
1185                                                 (format "[\\[%s]]" s))
1186                                                " "
1187                                                s)
1188                                       .
1189                                       ,s)))
1190                     ))))
1191   
1192
1193
1194;;;; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1195;;;; Commands
1196;;;; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1197;; prefix: plcmp-cmd-
1198
1199;;; complete-all
1200(defvar plcmp-completion-all-static-sources
1201  '(
1202    plcmp-anything-source-completion-buffer-dabbrevs
1203    plcmp-anything-source-completion-current-buffer-variables
1204    plcmp-anything-source-completion-current-buffer-arrays
1205    plcmp-anything-source-completion-current-buffer-hashes
1206    plcmp-anything-source-completion-current-buffer-functions
1207    plcmp-anything-source-completion-builtin-variables
1208    plcmp-anything-source-completion-builtin-functions   
1209    plcmp-anything-source-completion-other-perl-buffers-words
1210    plcmp-anything-source-completion-using-modules   
1211    plcmp-anything-source-completion-installed-modules
1212    ))
1213
1214(defun plcmp-get-sources-for-complete-all ()
1215  (append
1216   (plcmp-get-methods-completion-sources plcmp-using-modules)
1217   plcmp-completion-all-static-sources))
1218
1219(define-plcmp-command complete-all ()
1220  (anything (plcmp-get-sources-for-complete-all) plcmp-initial-input))
1221
1222
1223;;; smart-complete
1224(defsubst* plcmp-preceding-string (&optional (count 1))
1225  "現在の位置からcount文字前方位置までの文字列を返す
1226例外を出さない"
1227  (buffer-substring-no-properties
1228   (point)
1229   (condition-case nil
1230       (save-excursion (backward-char count) (point))
1231     (error (point)))))
1232
1233(defsubst plcmp-method-p ()
1234  (string-equal "->" (plcmp-preceding-string 2)))
1235
1236(defun plcmp--get-context-symbol ()
1237  "return list (context-symbol module-name-string) or list (context-symbol) if not module context.
1238context-symbol is one of the following values:
1239self
1240method
1241variable
1242array
1243hash
1244function
1245installed-module
1246otherwise
1247"
1248  (ignore-errors
1249    (save-excursion
1250      (let* ((start (point))
1251             (start-input (progn (skip-syntax-backward "w_") ;move point
1252                                 (buffer-substring-no-properties (point) start)))
1253             (obj-str (buffer-substring-no-properties ;string
1254                       (or (ignore-errors (save-excursion (forward-char -2) (point)))
1255                           (point))
1256                       (save-excursion (or (ignore-errors (backward-sexp)
1257                                                          (point))
1258                                           (point)))))
1259             (context-sym-str-list
1260              (cond
1261               ;; fullname
1262               ;; File::Copy::`!!'
1263               ((save-excursion
1264                  (goto-char start)
1265                  (skip-chars-backward "a-zA-Z0-9_")
1266                  (let ((str (plcmp-preceding-string 2)))
1267                    (when (string-equal str "::")
1268                      (backward-char 2)
1269                      (let* ((start (point))
1270                             (end (progn (skip-syntax-backward "w_")
1271                                         (point)))
1272                             (obj-str (buffer-substring-no-properties
1273                                       start
1274                                       end)))
1275                        (values 'method obj-str))))))
1276               ;; package
1277               ;; $self->`!!'
1278               ;; __PACKAGE__->`!!'
1279               ((and (plcmp-method-p)
1280                     (string-match (rx bol
1281                                       (or "$self"
1282                                           "__PACKAGE__")
1283                                       eol)
1284                                   obj-str))
1285                (list 'package))
1286               ;; method
1287               ;; Foo->`!!'
1288               ((and (plcmp-method-p)
1289                     (stringp obj-str))
1290                (list 'method obj-str))
1291               ;; variable
1292               ;; $foo`!!'
1293               ((string-equal "$" (plcmp-preceding-string 1))
1294                (list 'variable))
1295               ;; array
1296               ((string-equal "@" (plcmp-preceding-string 1))
1297                (list 'array))
1298               ;; hash
1299               ((string-equal "%" (plcmp-preceding-string 1))
1300                (list 'array))
1301               ;; function
1302               ((string-equal "&" (plcmp-preceding-string 1))
1303                (list 'function))
1304               ;; installed-module
1305               ;; use `!!'
1306               ((string-match (rx bol (* space) "use" (+ space))
1307                              (buffer-substring (point-at-bol) (point)))
1308                (list 'installed-module))
1309               (t
1310                (list 'otherwise)))))
1311        (prog1 context-sym-str-list
1312          (plcmp-log "plcmp--get-context-symbol: %s" context-sym-str-list))))))
1313
1314;; TODO
1315(defun plcmp-get-sources-for-smart-complete ()
1316  "return sources"
1317  (let* ((context-sym-str-list (plcmp--get-context-symbol))
1318         (ctx-sym (first context-sym-str-list))
1319         (module-name (second context-sym-str-list)))
1320    (let ((all-sources (plcmp-get-sources-for-complete-all)))
1321      (case ctx-sym
1322        (method (let ((sources (plcmp-re-sort-sources "method"
1323                                                      all-sources)))
1324                  (if (stringp module-name)
1325                      (let ((obj (assoc-default module-name plcmp-obj-instance-of-module-maybe-alist)))
1326                        (if (and obj
1327                                 (stringp obj))
1328                            (plcmp-re-sort-sources obj sources)
1329                          (plcmp-re-sort-sources module-name sources)))
1330                    sources)))
1331        (variable (plcmp-re-sort-sources "variable"
1332                                         all-sources))
1333        (array (plcmp-re-sort-sources  "array"
1334                                       all-sources))
1335        (hash (plcmp-re-sort-sources "hash"
1336                                     all-sources))
1337        (function (plcmp-re-sort-sources "function"
1338                                         all-sources))
1339        (installed-module (plcmp-re-sort-sources "installed modules"
1340                                                 all-sources))
1341        (otherwise (let* ((sources (plcmp-re-sort-sources "method"
1342                                                         all-sources
1343                                                         t))
1344                          (sources (plcmp-re-sort-sources "variable"
1345                                                          sources))
1346                          (sources (plcmp-re-sort-sources "function"
1347                                                          sources)))
1348                     sources))))))
1349
1350(define-plcmp-command smart-complete ()
1351  (plcmp-log "smart-complete called line: %s`!!'"
1352             (buffer-substring (point-at-bol) (point)))
1353  (anything (plcmp-get-sources-for-smart-complete) plcmp-initial-input))
1354
1355
1356;;; complete-variables
1357(defvar plcmp-completion-variable-static-sources
1358  '(
1359    plcmp-anything-source-completion-current-buffer-variables
1360    plcmp-anything-source-completion-builtin-variables
1361    ))
1362
1363(defun plcmp-get-sources-for-complete-variables ()
1364  (append
1365   plcmp-completion-variable-static-sources
1366   (plcmp-get-sources-other-perl-buffers-variable)))
1367
1368(define-plcmp-command complete-variables ()
1369  (anything (plcmp-get-sources-for-complete-variables) plcmp-initial-input))
1370
1371;;; document
1372(defvar plcmp-show-doc-sources
1373  '(
1374    plcmp-anything-source-doc-using-modules
1375    plcmp-anything-source-doc-man-pages
1376    plcmp-anything-source-doc-installed-modules
1377    ))
1378(define-plcmp-command show-doc ()
1379  (anything plcmp-show-doc-sources))
1380
1381(defun plcmp-cmd-menu ()
1382  (interactive)
1383  (anything '(plcmp-anything-source-menu)))
1384
1385(defun plcmp-cmd-clear-all-caches ()
1386  (interactive)
1387  (dolist (variable plcmp--cached-variables)
1388    (set variable nil))
1389  (or plcmp-installed-modules
1390      (plcmp-with-set-perl5-lib
1391       (plcmp--installed-modules-asynchronously)))
1392  (message "cleared all caches and getting installed modules asynchronously"))
1393
1394;; TODO
1395(defun plcmp-cmd-show-environment ()
1396  (interactive)
1397  (require 'custom)
1398  (let* ((decode-fn (lambda (s)
1399                      (if enable-multibyte-characters
1400                          (decode-coding-string s locale-coding-system t)
1401                        s)))
1402         (buf (get-buffer-create "*perl-completion show environment*"))
1403         (customs)
1404         (commands)
1405         (plcmp-symbols (loop for sym being symbols
1406                              for s = (symbol-name sym)
1407                              when (and (string-match "^plcmp-" s)
1408                                        (custom-variable-p sym))
1409                              collect s into custom-syms
1410                              when (string-match (concat "^" "plcmp-cmd-") s)
1411                              collect s into command-syms
1412                              finally do (setq customs custom-syms
1413                                               commands command-syms))))
1414    (with-current-buffer buf
1415      (erase-buffer)
1416      ;; process-environment
1417      (loop for env in process-environment
1418            do (progn (insert (funcall decode-fn (or env "")))
1419                      (insert "\n")))
1420      ;; customize-variables
1421      (insert "customize-variables:\n\n")
1422      (plcmp-insert-each-line customs)
1423      ;;custom-variable-p
1424      (switch-to-buffer buf))))
1425
1426(defun plcmp-cmd-update-check ()
1427  (interactive)
1428  (when (require 'url nil t)
1429    (let* ((uri "http://svn.coderepos.org/share/lang/elisp/perl-completion/trunk/perl-completion.el")
1430           (buf (url-retrieve-synchronously uri))
1431           (re (rx "plcmp-version " (group (+ (or (any digit) "."))))))
1432      (with-current-buffer buf
1433        (goto-char (point-min))
1434        (let ((trunk-version (prog1 (when (re-search-forward re nil t)
1435                                      (string-to-number (match-string-no-properties 1)))
1436                               (kill-buffer buf))))
1437          (if (< plcmp-version trunk-version)
1438            (when (y-or-n-p "new version available. Open URL in the default browser? ")
1439              (browse-url-default-browser uri))))))))
1440
1441
1442;; set-perl5lib
1443(defun plcmp-cmd-set-additional-lib-directory ()
1444  "ask directory, then set directory to `plcmp-additional-lib-directories'"
1445  (interactive)
1446  (let* ((dir (read-directory-name "set to PERL5LIB(this buffer only): " nil nil t))
1447         (dir (directory-file-name dir)))
1448    (when (and (stringp dir)
1449               (file-exists-p dir))
1450      (add-to-list 'plcmp-additional-lib-directories dir)
1451      (message "added %s to PERL5LIB" dir))))
1452
1453
1454;;; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1455;;; Mode
1456;;; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1457
1458;;; keymap
1459(defvar plcmp-mode-map
1460  (let ((map (make-sparse-keymap)))
1461    (define-key map (kbd "C-RET") 'plcmp-cmd-smart-complete)
1462    (define-key map (kbd "C-<return>") 'plcmp-cmd-smart-complete)
1463    (define-key map (kbd "C-c a") 'plcmp-cmd-complete-all)
1464    (define-key map (kbd "C-c v") 'plcmp-cmd-complete-variables)
1465    (define-key map (kbd "C-c c") 'plcmp-cmd-clear-all-caches)
1466    (define-key map (kbd "C-c d") 'plcmp-cmd-show-doc)
1467    (define-key map (kbd "C-c m") 'plcmp-cmd-menu)
1468
1469    map))
1470
1471(define-minor-mode perl-completion-mode "" nil " PLCompletion" plcmp-mode-map nil
1472  (or plcmp-installed-modules
1473      (plcmp-with-set-perl5-lib
1474       (plcmp--installed-modules-asynchronously))))
1475
1476
1477;;;; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1478;;;; Test
1479;;;; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1480
1481(dont-compile
1482  (when (fboundp 'expectations)
1483    (expectations
1484      (desc "define-plcmp-command macro expand")
1485      (expect '(defun plcmp-cmd-test (arg1 arg2)
1486                 (interactive)
1487                 (cl-block-wrapper
1488                  (catch (quote --cl-block-plcmp-cmd-test--)
1489                    (unwind-protect
1490                        (progn (plcmp-initialize-variables)
1491                               (progn "body"))
1492                      (plcmp-cleanup)))))
1493        (macroexpand-all
1494         '(define-plcmp-command test (arg1 arg2)
1495            "body")))
1496      (desc "plcmp-get-face-words")
1497      (expect nil
1498        (let ((b (get-buffer-create "*plcmp-test*")))
1499          (with-current-buffer b
1500            (cperl-mode)
1501            (plcmp-get-face-words))))
1502      (expect "$test"
1503        (let ((b (get-buffer-create "*plcmp-test*")))
1504          (with-current-buffer b
1505            (erase-buffer)
1506            (insert "my $test = 'hoge';\n")
1507            (cperl-mode)
1508            (font-lock-mode t)
1509            (font-lock-fontify-region (point-min) (point-max))
1510            (prog1 (car (plcmp-get-face-words))
1511              (kill-buffer b)))))
1512      (desc "plcmp--mk-module-source")
1513      (expect nil
1514        (plcmp--mk-module-source nil))
1515      (expect nil
1516        (let ((plcmp-module-methods-alist nil))
1517          (plcmp--mk-module-source "test")))
1518      (expect '((name . "module Methods") (type . plcmp-completion) (init lambda nil (with-current-buffer (anything-candidate-buffer (quote global)) (plcmp-insert-each-line (quote ("method" "method2"))))) (candidates-in-buffer))
1519        (let ((plcmp-module-methods-alist '(("module" . ("method" "method2")))))
1520          (plcmp--mk-module-source "module")))
1521
1522      (desc "plcmp-tramp-p")
1523      (expect t
1524        (require 'tramp)
1525        (stub plcmp-get-current-directory => "/tramp:path/to/")
1526        (when (plcmp-tramp-p)
1527          t))
1528
1529      (desc "plcmp-sort-sources")
1530      (expect 'plcmp-anything-source-completion-builtin-variables
1531        (car (plcmp-re-sort-sources "variables" plcmp-completion-all-static-sources)))
1532
1533      (desc "plcmp--get-lib-path")
1534      (expect "~/c/plagger/lib"
1535        (stub plcmp-get-current-directory => "~/c/plagger/lib/Plagger/TT/Plagger/")
1536        (plcmp--get-lib-path))
1537      (expect "~/c/plagger/lib"
1538        (stub plcmp-get-current-directory => "~/c/plagger/lib/Plagger/TT/Plagger")
1539        (plcmp--get-lib-path))
1540      (expect "~/c/hoge/plagger/lib/Plagger/TT/Plagger/lib"
1541        (stub plcmp-get-current-directory => "~/c/hoge/plagger/lib/Plagger/TT/Plagger/lib/test")
1542        (stub file-exists-p => t)
1543        (plcmp--get-lib-path))
1544      (expect "~/c/hoge/plagger/lib/Plagger/TT/Plagger/lib"
1545        (stub plcmp-get-current-directory => "~/c/hoge/plagger/lib/Plagger/TT/Plagger/lib/test/")
1546        (stub file-exists-p => t)
1547        (plcmp--get-lib-path))
1548      (expect nil
1549        (stub plcmp-get-current-directory => "")
1550        (plcmp--get-lib-path))
1551      )))
1552
1553
1554
1555(provide 'perl-completion)
1556;;; perl-completion.el ends here
Note: See TracBrowser for help on using the browser.