;;; -*- Emacs-Lisp -*-
;;; Perl mode plus
;;; (c) 1995-2000, 2005 by HIROSE Yuuji [yuuji>at<gentei.org]
;;; $Id: perlplus.el,v 1.3 2009/10/04 12:29:06 yuuji Exp yuuji $
;;; Last modified Mon Nov  4 10:59:04 2019 on firestorm

;;; [Commentary]
;;; 
;;; This package enables function/variable name completion on perl-mode.
;;; (Use this package with your favorite perl-editing mode.)
;;; 
;;; [How to use]
;;; 
;;; Put the next lines into your ~/.emacs
;;; 
;;; 	(setq perl-mode-hook
;;;	  '(lambda ()
;;; 	     (require 'perlplus)
;;;	     (define-key perl-mode-map "\M-\t" 'perlplus-complete-symbol)
;;;	     (perlplus-setup)))
;;; 
;;; If you  are using cperl-mode,  replace  all `perl-mode's above  with
;;; cperl-mode.
;;; 
;;; [Description]
;;; 
;;; Once you have set  up as above, you  can use M-TAB to complete  perl
;;; symbol (built-in functions,  user  defined functions  and variables)
;;; including  require-ed  perl libraries.   If  you modify the required
;;; library (by current source text), call M-x  perl-mode (or other mode
;;; you are using) again from referring perl buffer.
;;; 
;;; If the  file `foo.pl' is required  and found  in system perl library
;;; directory which  is specified  by  the  second  list's part of  each
;;; element of the variable perlplus-inc-path-alist (see the description
;;; of   the  variable), or `foo.pl'  is    set to read-only  attribute,
;;; `foo.pl' is read only once  even if the function `perlplus-setup' is
;;; read more than  once.  This causes the  symbol collection  speed up,
;;; but inconsistency  of   symbol  completion  table when  you   modify
;;; `foo.pl'.  If you need to synchronize completion table, call;
;;; 
;;;	M-x perlplus-reset
;;; 
;;; このプログラムを使うことにより、Perl のシンボル({内部,外部}{関数,変
;;; 数})を ESC TAB で補完できるようになります。カレントファイルで参照し
;;; ているライブラリファイルを変更した場合は、カレントバッファで再度
;;; 
;;;	M-x perl-mode
;;;	(あるいはあなたの使っている Perl 編集モードコマンド)
;;; 
;;; とすることで、外部シンボルの変更をカレントファイルに反映させることが
;;; できます。 ただし、変数 perlplus-inc-path-alist で system 属性が付け
;;; られているディレクトリにあるperlライブラリ、または readonly のライブ
;;; ラリファイル中のシンボルはファイル読み込みと同時に perlplus の内部変
;;; 数に格納され再度読み込まれることはありません。もし、このようなライブ
;;; ラリファイルに修正を加えて補完テーブルに食い違いが生じた場合は
;;; 
;;;	M-x perlplus-reset
;;; 
;;; として、内部補完テーブルの初期化を行って下さい。
;;; 
;;; [NO WARRANTY]
;;; 
;;; This  program  is distributed    as a   free   software.   You   can
;;; redistribute this software  freely but with  NO warranty to anything
;;; as   a result  of  using this   software.   However, any reports and
;;; suggestions   are welcome as   long  as I  feel   interests  in this
;;; software.
;;; 
;;; このプログラムはフリーソフトウェアとして配布致します。本プログラムを
;;; 利用することにより生じた結果に関して、作者は一切の責任を負いかねます
;;; のでご注意下さい。バグレポート/コメント等は歓迎致します。連絡は以下
;;; のアドレスまでお願い致します。
;;; 
;;; 							   HIROSE, Yuuji
;;; 							yuuji@gentei.org

(defvar perlplus-inc-path-alist
  '(("/usr/local/lib/perl" . system)
    ("/usr/local/lib/perl5" . system)
    ("/usr/share/perl" . system)
    ("." . user))
  "* @INC path alist of perl;
ex.
'((PATH1 . system)
  (PATH2 . user))
The car of a list is path name of @INC directory, and the cdr of a list should
one of 'system or 'user, which specifies if that perl library is system
library or not.  When system library, perlplus won't read library files
twice.  When user library, perlplus reads them everytime you call perl mode.")
(defvar perlplus-perl5 nil "If the perl is version 5")
(defvar perlplus-function-open "("
  "*Function's argument starting character.
If you don't like parenthesizing function's arguments, set \" \".")

(defvar perlplus-system-function-alist nil)
(defvar perlplus-system-variable-alist nil)
(defvar perlplus-perl-symbol-regexp "[A-Za-z_][A-Za-z_0-9\':]*"
  "Regexp of perl symbol names")
(defvar perlplus-perl-symbol-regexp2 "[A-Za-z_0-9\':]*"
  "Regexp of the second character or later of perl symbol names")
(defvar perlplus-external-functions nil "External function list")
(defvar perlplus-external-variables nil "External variable list")

(defvar perlplus-builtin-function-alist
  '(
    ("accept") ("alarm") ("atan2") ("bind") ("binmode") ("caller") ("chdir")
    ("chmod") ("chop") ("chown") ("chroot") ("close") ("closedir") ("cmp")
    ("connect") ("cos") ("crypt") ("dbmclose") ("dbmopen") ("defined")
    ("delete") ("die") ("do") ("dump") ("each") ("endgrent") ("endhostent")
    ("endnetent") ("endprotoent") ("endpwent") ("endservent") ("eof") ("eq")
    ("eval") ("exec") ("exit") ("exp") ("fcntl") ("fileno") ("flock")
    ("for") ("foreach") ("fork") ("ge") ("getc") ("getgrent") ("getgrgid")
    ("getgrnam") ("gethostbyaddr") ("gethostbyname") ("gethostent")
    ("getlogin") ("getnetbyaddr") ("getnetbyname") ("getnetent")
    ("getpeername") ("getpgrp") ("getppid") ("getpriority")
    ("getprotobyname") ("getprotobynumber") ("getprotoent") ("getpwent")
    ("getpwnam") ("getpwuid") ("getservbyname") ("getservbyport")
    ("getservent") ("getsockname") ("getsockopt") ("gmtime") ("goto")
    ("grep") ("gt") ("hex") ("if") ("index") ("int") ("ioctl") ("join")
    ("keys") ("kill") ("last") ("le") ("length") ("link") ("listen")
    ("local") ("localtime") ("log") ("lstat") ("lt") ("mkdir") ("msgctl")
    ("msgget") ("msgrcv") ("msgsnd") ("ne") ("next") ("oct") ("open")
    ("opendir") ("ord") ("pack") ("package") ("pipe") ("pop") ("print")
    ("printf") ("push") ("rand") ("read") ("readdir") ("readlink") ("recv")
    ("redo") ("rename") ("require") ("reset") ("return") ("reverse")
    ("rewinddir") ("rindex") ("rmdir") ("scalar") ("seek") ("seekdir")
    ("select") ("semctl") ("semget") ("semop") ("send") ("setgrent")
    ("sethostent") ("setnetent") ("setpgrp") ("setpriority") ("setprotoent")
    ("setpwent") ("setservent") ("setsockopt") ("shift") ("shmctl")
    ("shmget") ("shmread") ("shmwrite") ("shutdown") ("sin") ("sleep")
    ("socket") ("socketpair") ("sort") ("splice") ("split") ("sprintf")
    ("sqrt") ("srand") ("stat") ("study") ("substr") ("symlink") ("syscall")
    ("sysread") ("system") ("syswrite") ("tell") ("telldir") ("time")
    ("times") ("truncate") ("umask") ("undef") ("unless") ("unlink")
    ("unpack") ("unshift") ("until") ("utime") ("values") ("vec") ("wait")
    ("waitpid") ("wantarray") ("warn") ("while") ("write")
    )
  "Alist of Perl's built-in functions")

(defvar perlplus-control-structure-alist
  '(("if") ("while") ("unless") ("foreach"))
  "Alist of control structure of perl")

(defun perlplus-get-package-name ()
  (save-excursion
    (if (progn (goto-char (point-min))
	       (re-search-forward "package +\\([^;]*\\);" nil t))
	(let ((p (buffer-substring (match-beginning 1) (match-end 1))))
	  (if (equal p "main")
	      ""
	    (concat p (if perlplus-perl5 "::" "'"))))
      "")))

(defun perlplus-matching-functions-internal (initial &optional packagename)
  "Return the function names as a list."
  (save-excursion
    (setq packagename (if packagename (perlplus-get-package-name) ""))
    (let ((subrx (concat "^sub *\\(" perlplus-perl-symbol-regexp "\\)"))
	  list ini w)
      (setq ini (concat "^" (regexp-quote initial)))
      (goto-char (point-min))
      (while (re-search-forward subrx nil t)
	(if (string-match
	     ini (setq w (buffer-substring (match-beginning 1) (match-end 1))))
	    (progn
	      (or (string-match ".+\\('\\|::\\).+" w)
		  (setq w (concat packagename w)))
	      (setq list (cons (list w) list)))))
      list
      ;;(try-completion initial list)
      )))

(defun perlplus-match-list (initial alist)
  (let ((l alist) ml)
    (setq initial (concat "^" (regexp-quote initial)))
    (while l
      (if (string-match initial (car (car l)))
	  (setq ml (cons (car l) ml)))
      (setq l (cdr l)))
    ml))

(defun perlplus-matching-functions (initial)
  (append (perlplus-matching-functions-internal initial)
	  (perlplus-match-list initial perlplus-external-functions)))

(defun perlplus-function-completion (initial)
  (try-completion initial
		  (append
		   (perlplus-matching-functions initial)
		   perlplus-external-functions)))

(defun perlplus-matching-variables-local (initial)
  "Return the local variable names as a list."
  (let ((p (point)) e vlist word (case-fold-search nil))
    (save-excursion
      ;;(perl-beginning-of-function)
      (re-search-backward "^sub .*" nil 1)
      (if (= (point) (point-min))
	  nil
	(while (re-search-forward "\\<\\(local\\|my\\)\\s *(" p t)
	  (goto-char (1- (match-end 0)))
	  (setq e (save-excursion (forward-list 1) (point)))
	  (while (re-search-forward
		  (concat
		   "[\$@%\*]{?\\("
		   initial perlplus-perl-symbol-regexp2 "\\)") e t)
	    (setq word (buffer-substring
			(match-beginning 1) (match-end 1)))
	    (setq vlist (cons (list word) vlist)))
	  (goto-char (1+ e)))))
    vlist))

(defun perlplus-re-search-active-forward (regexp &optional bound noerror count rv)
  "Search regular expression in non-commented line."
  (let ((func (if rv 're-search-backward 're-search-forward)))
    (catch 'found
      (while (funcall func regexp bound noerror count)
	(if (save-excursion
	      (beginning-of-line)
	      (re-search-forward "[^$\\]?#" (match-beginning 0) t))
	    nil
	  (throw 'found t))))))


(defun perlplus-matching-variables-global (initial &optional packagename)
  "Return the global variable names as a list.
This function only investigates top level's variables.
Optional second argument PACKAGENAME append the package name"
  (let (vlist op word (case-fold-search nil) (p (point)))
    (save-excursion
      (setq packagename (if packagename (perlplus-get-package-name) ""))
      (goto-char (point-min))
      (while (not (eobp))
	(save-excursion
	  (if (perlplus-re-search-active-forward "^[ \t]*sub .* {" nil t)
	      (setq op (1- (match-end 0)))
	    (setq op (point-max))))
	(while (perlplus-re-search-active-forward
		;; "[\$@]\\([A-z_][A-Z_0-9\':]\\)*"
		(concat "[\$%@]\\("
			initial perlplus-perl-symbol-regexp2 "\\)") op t)
	  (setq word (buffer-substring (match-beginning 1) (match-end 1)))
	  (if packagename (setq word (concat packagename word)))
	  (or (assoc word vlist)
	      (string-match ".*\\('\\|::\\).*\\('\\|::\\)" word)
	      (= p (match-beginning 1))
	      (= p (match-end 0))
	      (setq vlist (cons (list word) vlist))))

	(goto-char op)
	;;(forward-list 1)
	(cond
	 ((condition-case err
	      (forward-list 1)
	    (error nil)))
	 ((re-search-forward "^sub .*{\\|^} *$" nil t)))
	))
    vlist))

(defun perlplus-matching-variables (initial)
  "Return the variable names as a list."
  (append (perlplus-matching-variables-local initial)
	  (perlplus-matching-variables-global initial)
	  (perlplus-match-list initial perlplus-external-variables)))
(defun perlplus-variable-completion (initial)
  (try-completion initial (perlplus-matching-variables initial)))
(defun perlplus-collect-imported-symbols1 ()
  (let ((cb (current-buffer))
	reqfiles rlist file plist dir vlist flist vl fl rl sys)
    (save-excursion
      (goto-char (point-min))
      (while (re-search-forward
	      ;"^[^#]*\\s \\(require\\|use\\) +\\([\"']\\)\\([^\";']+\\)\\2;"
	      "[\n\t ]\\(require\\|use\\) +\\([\"']\\)\\([^\";']+\\)\\2;"
	      ;"\\<\\(require\\|use\\) +\"\\(.+\\)\";"
	      nil t)
	(if (save-excursion
	      (save-match-data
		(let ((b (match-beginning 0)))
		  (beginning-of-line)
		  (search-forward "#" b t))))
	    (goto-char (match-end 0))
	  (setq reqfiles
		(cons (buffer-substring (match-beginning 3) (match-end 3))
		      reqfiles)))))
    (while reqfiles
      (setq file (car reqfiles))
      (setq plist perlplus-inc-path-alist)
      (if (assoc file perlplus-system-variable-alist) (setq plist nil))
      (while plist
	(setq dir (car (car plist))
	      sys (eq 'system (cdr (car plist))))
	(if (file-directory-p dir)
	    (if (file-exists-p (expand-file-name file dir))
		(let ((hilit-auto-highlight nil ))
		  (message "Collecting symbols in %s..." file)
		  (set-buffer (find-file-noselect (expand-file-name file dir)))
		  (setq rl (perlplus-collect-imported-symbols)
			vl (or (cdr-safe
				(assoc file perlplus-system-variable-alist))
			       (perlplus-matching-variables-global "" t))
			fl (or (cdr-safe
				(assoc file perlplus-system-function-alist))
			       (perlplus-matching-functions-internal "" t))
			vlist (append vlist vl (car rl))
			flist (append flist fl (car (cdr rl))))
		  (if (and (or sys buffer-read-only)
			   (null (assoc file perlplus-system-function-alist)))
		      (progn
			(setq perlplus-system-function-alist
			      (cons
			       (cons file fl) perlplus-system-function-alist)
			      perlplus-system-variable-alist
			      (cons
			       (cons file vl) perlplus-system-variable-alist))
			(kill-buffer nil)))
		  (set-buffer cb)
		  (message "Collecting symbols in %s...Done" file)
		  (setq plist nil))
	      ))
	(setq plist (cdr plist)))
      (setq reqfiles (cdr reqfiles)))
    (list vlist flist)))

(defun perlplus-collect-imported-symbols ()
  (let (perlplus:visited)
    (perlplus-collect-imported-symbols1)))
;;;
;; flash-string from rp-describe-function.el
;;;
(defun perlplus-flash-string (STRING)
  "Momentarily display STRING in the buffer; erase it on the next keystroke.
The string is displayed starting on the line after point.  The window is
recentered if necessary to make the whole string visible.  If the window isn't
large enough, at least you get to read the beginning."
  (let ((buffer-read-only nil)
        (modified (buffer-modified-p))
        (name buffer-file-name)
        insert-start
        insert-end)
    (unwind-protect
        (progn
          (save-excursion
            ;; defeat file locking... don't try this at home, kids!
            (setq buffer-file-name nil)
            (forward-line 1)
            (setq insert-start (point))
            (insert STRING)
            (setq insert-end (point)))
          ; make sure the whole string is visible
          (if (not (pos-visible-in-window-p insert-end))
            (recenter (max 0
                           (- (window-height)
                              (count-lines insert-start insert-end)
                              2))))
          (message "Type %s to continue editing..."
                   (single-key-description ?\ ))
          (let ((char (read-char)))
            (or (eq char ?\ )
                (setq unread-command-char char))))
      (if insert-end
          (save-excursion
            (delete-region insert-start insert-end)))
      (setq buffer-file-name name)
      (set-buffer-modified-p modified))))


(defun perlplus-reset ()
  "Reset perlplus internal symbol table."
  (interactive)
  (setq perlplus-system-function-alist nil
	perlplus-system-variable-alist nil)
  (let ((blist (buffer-list)))
    (while blist
      (set-buffer (car blist))
      (and (boundp 'perlplus-external-variables)
	   perlplus-external-variables
	   (message "Resetting %s..." (buffer-name))
	   (funcall major-mode)
	   (message "Resetting %s...Done" (buffer-name)))
      (setq blist (cdr blist)))))

(defun perlplus-complete-symbol ()
  "Complete perl symbol dynamically."
  (interactive)
  (let ((p (point)) b abr word listfunc ps w (ww (window-width)) (len 0))
    (save-excursion
      (or (string-match
	   "[A-Z_0-9':]" (char-to-string (char-after (1- (point)))))
	  (error "Cannot complete here!"))
      ;;(skip-chars-backward "^ \"(\t\n")
      (skip-chars-backward "A-Za-z_0-9\':")
      (setq abr (buffer-substring (point) p))
      (cond
       ((and (not (bolp)) (= (char-after (1- (point))) ?&))	;function
	(setq b (point)
	      listfunc 'perlplus-matching-functions
	      word (perlplus-function-completion abr)
	      ps perlplus-function-open))
       ((and (not (bolp))					;variable
	     (or
	      (string-match
	       "[\$%@]" (char-to-string (char-after (1- (point)))))
	      (save-excursion
		(forward-char -2)
		(and (looking-at "[\$%@]{") (setq ps "}")))))
	(setq b (point)
	      listfunc 'perlplus-matching-variables
	      word (perlplus-variable-completion abr)))
       ((looking-at "[A-Za-z_]")				;keyword
	(setq b (point))
	(setq listfunc
	      '(lambda (x)
		 (perlplus-match-list x perlplus-builtin-function-alist))
	      word (try-completion abr perlplus-builtin-function-alist)
	      ps perlplus-function-open))
       (t (setq word 1))))
    (cond
     ((stringp word)
      (if (string= word abr)
	  (let ((cand "") (list (funcall listfunc abr)))
	    (while list
	      (setq w (car (car list)))
	      (if (> (+ len (length w) 2) ww)
		  (setq w (concat "\n" w "  ") len (+ (length w) 2))
		(setq w (concat w "  ") len (+ len (+ (length w) 2))))
	      (setq cand (concat cand w)
		    list (cdr list)))
	    (perlplus-flash-string
	     (format "== Matches with %s\n%s\n%s"
		     (make-string (- (window-width) 16) ?=) cand
		     (make-string (1- (window-width)) ?=))))
	(delete-region b p)
	(insert word)
	(setq abr word)
	(setq word (try-completion word (funcall listfunc abr)))
	(if (eq t word)
	    (if (eolp)
		(cond
		 ((assoc abr perlplus-control-structure-alist)
		  (insert " ("))
		 (ps (insert ps)))))
	))
     ((null word)
      (error "No matches found for `%s'" abr))
     ((eq word t)
      (message "Sole completion")
      (cond
       ((assoc abr perlplus-control-structure-alist)
	(insert " ("))
       (ps (insert ps)))))))

(defun perlplus-setup ()
  (make-local-variable 'perlplus-external-variables)
  (make-local-variable 'perlplus-external-functions)
  (make-local-variable 'perlplus-inc-path-alist)
  (make-local-variable 'perlplus-perl5)
  (let ((symlist (perlplus-collect-imported-symbols))
	(st (syntax-table)))
    (set-syntax-table (standard-syntax-table))
    (unwind-protect
	(setq perlplus-external-variables (car symlist)
	      perlplus-external-functions (car (cdr symlist)))
      (set-syntax-table st)))
  )
(provide 'perlplus)

;;; Local variables:
;;; fill-prefix: ";;; "
;;; End: