;: -*- emacs-lisp -*-
;:* $Id: perl-sy.el,v 1.1 2003-10-18 01:10:00+10 steve Exp steve $
(require 'cperl-mode)
(defvar my-cperl-electric-parens)
;:*=======================
;:* perl-tab-to-comment
(setq perl-tab-to-comment t)
;:*=======================
;:* 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?

(defun my-cperl-mode-hook ()
  (setq cperl-mode t)
  (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-x`"    'perldb-next-error))

(add-hook 'cperl-mode-hook 'my-cperl-mode-hook)
(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)))

(defvar my-perl-info-nodes
  (sort 
   (append '(("TOC"  . "perltoc")
             ("Top"  . "Top")
             ("Perl" . "perl")
             ("0"    . "perlfaq")
             ("Func" . "Function Index")
             ("Var"  . "Variable Index")
             ("Diag" . "Diagnostic Message Index"))
           (mapcar (function (lambda (x) (cons x (concat "perl" x))))
                   '("delta" "faq" "data" "syn" "op" "re" "run" "func"
                     "var" "sub" "mod" "modlib" "form" "locale" "ref" "dsc"
                     "lol" "toot" "obj" "tie" "bot" "ipc" "debug" "diag" "sec"
                     "trap" "style" "pod" "book" "embed" "apio" "xs" "xstut"
                     "guts" "call"))
           (mapcar (function (lambda (x) 
                               (cons (int-to-string x)
                                     (format "perlfaq%d" x))))
                   '(1 2 3 4 5 6 7 8 9)))
   (function (lambda (x y) (string< (car x) (car y))))))

(defun my-perl-info (str)
  (interactive 
   (list (completing-read "Info perl: " my-perl-info-nodes nil t)))
  (Info-goto-node (concat "(perl)" (cdr (assoc str my-perl-info-nodes)))))

(defun my-perl-info-faq (num)
  (interactive
   (list (if current-prefix-arg (prefix-numeric-value current-prefix-arg)
           (read-number "Info perlfaq[1-9]: " 'int))))
  (my-perl-info (if (= num 0) "faq" (int-to-string num))))

(defmacro deftoggle (sym &optional get set comment before after message)
  "Define a function my-toggle-SYM to toggle SYM on and off.
   GET and SET are either nil in which case SYM and (setq SYM) are used,
   functions (eg default-value and set-default) called with SYM and SYM VAL,
   or (macro lambda (SYM) ...) and (macro lambda (SYM VAL) ...) respectively.
   COMMENT is additional comment for my-toggle-SYM,
   BEFORE and AFTER are lists of additional forms around the toggle code,
   MESSAGE is a (macro lambda (SYM VAL) ...) replacing the normal \"SYM is VAL.
\""
  (cond ((null get) (setq get sym))
        ((symbolp get) (setq get `(,get (quote ,sym))))
        ((setq get (macroexpand (list get sym)))))
  (let ((val `(if arg (> (prefix-numeric-value arg) 0) (not ,get))))
    (cond ((null set) (setq set `(setq ,sym ,val)))
          ((symbolp set) (setq set `(,set (quote ,sym) ,val)))
          ((setq set (macroexpand (list set sym val)))))
    `(defun ,(intern (concat "my-toggle-" (symbol-name sym))) (&optional arg)
       ,(concat "Toggle " (symbol-name sym) ". Return the new value.
   With positive ARG set it, with nonpositive ARG reset it."
                (if comment (concat "\n" comment)))
       (interactive "P")
       ,@before
       ,set
       ,@after
       (when (interactive-p)
         ,(if message (macroexpand (list message sym get))
            `(message "%s is %s" (quote ,sym) ,get)))
       ,get)))
;:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::*
(message "perl mode set succesfully.")

Copyright © 2003 Steve Youngs
Verbatim copying and distribution is permitted in any medium, providing this notice is preserved.
Last modified: Sat Oct 18 02:14:34 EST 2003