;;;;  Perl mode
;:* cperl-mode bindings by Vladimir Alexiev <vladimir @ cs.ualberta.ca>
;:  I myself hate it that cperl-mode takes away C-h v etc. Here's how I
;:  fix it, together with stuff to show the status of four electric flags
;:  on the modeline: "(" parens, ";" auto-newline, "'" keywords, ")" close 
;:  around region, and make "\C-c*" toggle the "*" flag.
(make-variable-buffer-local 'cperl-mode)
(setq-default cperl-mode nil)           ; is this buffer in cperl-mode?
(add-hook 'cperl-mode-hook
          (defun my-cperl-mode-hook ()
            (setq cperl-mode t)
            (setq cperl-auto-newline nil)
            (setq cperl-abbrev t)
            (setq cperl-pod-here-fontify t)
            (setq executable-magicless-file-regexp ".*\.pm$\\|.*\.t$")
            (executable-set-magic "/usr/bin/perl" "-w") 
            (setq cperl-tab-always-indent nil)
            (define-key cperl-mode-map [tab] 'my-tab)
            (cperl-find-pods-heres)
;	    (define-key cperl-mode-map "\C-c'" 'cperl-toggle-abbrev)
;	    (define-key cperl-mode-map "\C-c;" 'cperl-toggle-auto-newline)
;	    (define-key cperl-mode-map "\C-c)" (deftoggle cperl-electric-parens-mark))
;			(define-key cperl-mode-map "\C-c(" (deftoggle cperl-electric-parens
;												 cperl-val
;												 (macro lambda (sym val) `(setq ,sym (if ,val t 'null))) nil nil
;;												 ((setq my-cperl-electric-parens (cperl-val 'cperl-electric-parens)))))
;;			(setq my-cperl-electric-parens (cperl-val 'cperl-electric-parens))
;;			(unless (eq (caar minor-mode-alist) 'my-cperl-electric-parens)
;;			  (mapc #'(lambda (x)
;;						(setq minor-mode-alist
;;							  (cons x (delete x minor-mode-alist))))
;;					(nreverse '((my-cperl-electric-parens   (cperl-mode "("))
;;								(abbrev-mode                (cperl-mode "'"))
;;								(cperl-auto-newline         (cperl-mode ";"))
;;								(cperl-electric-parens-mark (cperl-mode ")"))))))
;	    (define-key cperl-mode-map "\C-hf" nil)
;	    (define-key cperl-mode-map "\C-hv" nil)
;	    (define-key cperl-mode-map "\C-c\C-v" 'send-perldb-command)
;	    (define-key cperl-mode-map "\C-c\M-+" 'cperl-beautify-regexp)
;	    (define-key cperl-mode-map "\C-c "    'cperl-find-bad-style)
;	    (define-key cperl-mode-map "\C-c="    'cperl-lineup)
            (define-key cperl-mode-map "\C-cc"    'cperl-check-syntax)
;	    (define-key cperl-mode-map "\C-cd"    'perldb-break)
;	    (define-key cperl-mode-map "\C-ch"    'cperl-find-pods-heres)
;	    (define-key cperl-mode-map "\C-cp"    'send-perldb-command) ; "print"
             (define-key cperl-mode-map "\C-hf"    'my-perlfunc)
             (define-key cperl-mode-map "\C-x`"    'perldb-next-error)))


;(global-set-key "\C-h\C-h" 'my-perl-help-map)
;(define-prefix-command 'my-perl-help-map)
;(define-key my-perl-help-map "\C-q" 'cperl-info-on-current-command)
;(define-key my-perl-help-map "\C-m" 'my-perldoc)
;(define-key my-perl-help-map "\C-i" 'my-perl-info)
;(define-key my-perl-help-map "\C-f" 'my-perl-info-faq)
;(define-key my-perl-help-map "\C-d" 'my-perldoc)
;(define-key my-perl-help-map "\C-@" 'cperl-get-help)
;(define-key my-perl-help-map [(control ?\ )] 'cperl-get-help)

(defvar my-perldoc-history nil)

(defun my-perldoc (arg)
  (interactive
   (progn
     (autoload 'cperl-word-at-point-hard "cperl")
     (let* ((def (cperl-word-at-point-hard))
            (arg (read-string (format "PerlDoc%s: " 
                                      (if def (format " (default %s)" def) ""))
                              my-perldoc-history)))
       (list (if (string= arg "") def arg)))))
  (let ((Manual-program "perldoc"))
    (manual-entry arg)))

(defun my-perlfunc (arg)
  (interactive
   (progn
     (autoload 'cperl-word-at-point-hard "cperl")
     (let* ((def (cperl-word-at-point-hard))
	    (arg (read-string (format "What Function:%s: " 
				      (if def (format " (default %s)" def) ""))
			      my-perldoc-history)))
       (list (if (string= arg "") def arg)))))
    (let ((Manual-program "perlfunc"))
      (manual-entry arg)
))

(defun pod-spell ()
  "A function to only check pod documentation"
  (interactive "*")
  (save-excursion
	(let ((element 0)
		  (my-list (make-pod-list)))
	  (while (< element (length my-list))
		(setq the-first (car (nth element my-list)))
		(setq the-second (cadr (nth element my-list)))
		(ispell-region (car (nth element my-list)) (cadr (nth element my-list)))
		(setq element (1+ element))))))

(defun make-pod-list ()
  "A function to make a list of syntactic elements which are pod/here documentation"
  (interactive)
  (goto-char (point-min))
  (let (
		(current 0)
		(pod-list '())
		(last-state nil)
		(done nil)
		(line 0)
		(pod-start 0))
	(while (not done)
	  (setq the-state (get-text-property current 'in-pod))
	  (cond
	   ((and (eq last-state nil) (eq the-state t))   ;; a new pod is starting
		(setq last-state the-state)
		(setq pod-start current))
	   ((and (eq last-state t) (eq the-state nil))   ;; the end of a pod
		(setq last-state the-state)
		(setq pod-list (cons (list pod-start current) pod-list)))
	   ((eq current (point-max))
		(setq done t)))
	  (setq line (1+ line))
	  (goto-line line)
	  (setq current (point)))  ;; end of the while loop.
	(reverse pod-list)))        ;; I reversed it just to make it prettier