← Back to branch summary

~ubuntu-branches/ubuntu/precise/emacs-goodies-el/precise-proposed

« back to all changes in this revision

Viewing changes to elisp/emacs-goodies-el/pod-mode.el

  • Committer: Bazaar Package Importer
  • Author(s): Reinhard Tartler
  • Date: 2010-11-12 18:45:23 UTC
  • mfrom: (4.1.22 sid)
  • Revision ID: james.westby@ubuntu.com-20101112184523-94acid3rtwowwsq1
Tags: 34.1ubuntu1
* Merge from debian unstable.  Remaining changes:
  - Add {hardy,jaunty,karmic,lucid,maverick}-proposed distribution targets
    to dpkg-dev-el.
  - Add natty{,-proposed} distribution targets; drop out the maverick
    non-proposed target, since uploads to the release pocket are not
    permitted for stable releases.

Show diffs side-by-side

added added

removed removed

Lines of Context:
elisp/emacs-goodies-el/pod-mode.el
6
6
 
7
7
;;; Author: Steffen Schwigon <ss5@renormalist.net>
8
8
;;;
9
 
;;; Keywords: emacs mode perl pod
 
9
;;; Keywords: perl pod
10
10
;;; X-URL: http://search.cpan.org/~schwigon/pod-mode/
11
11
 
12
12
;;; This program is free software; you can redistribute it and/or modify
21
21
;;;
22
22
;;; You should have received a copy of the GNU General Public License
23
23
;;; along with this program; if not, write to the Free Software
24
 
;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 
24
;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
 
25
;;; MA 02110-1301, USA.
25
26
 
26
 
;;; Tested on i386-linux with XEmacs 21.4.
27
 
;;; Tested on i386-linux with GNU Emacs 21.2.1.
28
 
;;; Tested on i386-windows-2k with XEmacs 21.4.
 
27
;;; This code is supposed to work on all platforms on both GNU Emacs
 
28
;;; and XEmacs at least as of version 21.2.1 and 21.4,
 
29
;;; respectively. Please speak up if it doesn't on your platform or
 
30
;;; recent-ish version of an Emacs of your choice
29
31
 
30
32
;;; Commentary:
31
33
 
38
40
;;;
39
41
;;;   http://renormalist.net/Renormalist/EmacsLanguageModeCreationTutorial
40
42
;;;
41
 
;;; Regexes are defined for the following font-lock-faces:
42
 
;;;
43
 
;;;   font-lock-keyword-face
44
 
;;;   font-lock-type-face
45
 
;;;   font-lock-comment-face
46
 
;;;   font-lock-reference-face
47
 
;;;   font-lock-doc-string-face
48
 
;;;   font-lock-function-name-face
49
 
;;;
50
43
 
51
44
;;; Usage:
52
45
 
57
50
;;;
58
51
;;; To associate pod-mode with .pod files add the following to your ~/.emacs
59
52
;;;
60
 
;;;    (setq auto-mode-alist
61
 
;;;       (append auto-mode-alist
62
 
;;;         '(("\\.pod$" . pod-mode))))
 
53
;;;    (add-to-list 'auto-mode-alist '("\\.pod$" . pod-mode))
63
54
;;;
64
55
;;;
65
56
;;; To automatically turn on font-lock-mode add the following to your ~/.emacs
66
57
;;;
67
58
;;;    (add-hook 'pod-mode-hook 'font-lock-mode)
68
59
;;;
 
60
;;;
 
61
;;; In addition to the standard POD commands, custom commands as
 
62
;;; defined by a Pod::Weaver configuration are supported. However, for
 
63
;;; those to work, eproject.el as available at
 
64
;;; http://github.com/jrockway/eproject is required.
 
65
;;;
 
66
;;; Make sure to require eproject.el or create an autoload for
 
67
;;; eproject-maybe-turn-on if you expect custom commands to work.
 
68
;;;
 
69
;;;
 
70
;;; When automatically inserting hyperlink formatting codes to modules
 
71
;;; or sections within modules, autocompletion for module names will
 
72
;;; be provided if perldoc.el, as available at
 
73
;;; git://gaffer.ptitcanardnoir.org/perldoc-el.git, is present.
 
74
;;;
69
75
 
70
76
;;; Code:
71
77
 
72
 
;; default variables
73
 
(defvar pod-mode-hook nil)
 
78
(require 'cl)
 
79
 
 
80
(defgroup pod-mode nil
 
81
  "Mode for editing POD files"
 
82
  :group 'faces)
 
83
 
 
84
(defgroup pod-mode-faces nil
 
85
  "Faces for highlighting POD constructs"
 
86
  :prefix "pod-mode-"
 
87
  :group 'pod-mode)
 
88
 
 
89
(defface pod-mode-command-face
 
90
  '((((class grayscale) (background light)) (:foreground "LightGray" :weight bold))
 
91
    (((class grayscale) (background dark)) (:foreground "DimGray" :weight bold))
 
92
    (((class color) (min-colors 88) (background light)) (:foreground "Purple"))
 
93
    (((class color) (min-colors 88) (background dark)) (:foreground "Cyan1"))
 
94
    (((class color) (min-colors 16) (background light)) (:foreground "Purple"))
 
95
    (((class color) (min-colors 16) (background dark)) (:foreground "Cyan"))
 
96
    (((class color) (min-colors 8)) (:foreground "cyan" :weight bold))
 
97
    (t (:weight bold)))
 
98
  "Face used to highlight POD commands"
 
99
  :group 'pod-mode-faces)
 
100
 
 
101
(defface pod-mode-head-face
 
102
  '((t (:inherit pod-mode-command-face)))
 
103
  "Face used to highlight =head commands"
 
104
  :group 'pod-mode-faces)
 
105
 
 
106
(defface pod-mode-command-text-face
 
107
  '((((class grayscale) (background light))
 
108
     (:foreground "DimGray" :weight bold :slant italic))
 
109
    (((class grayscale) (background dark))
 
110
     (:foreground "LightGray" :weight bold :slant italic))
 
111
    (((class color) (min-colors 88) (background light))
 
112
     (:foreground "Firebrick"))
 
113
    (((class color) (min-colors 88) (background dark))
 
114
     (:foreground "chocolate1"))
 
115
    (((class color) (min-colors 16) (background light))
 
116
     (:foreground "red"))
 
117
    (((class color) (min-colors 16) (background dark))
 
118
     (:foreground "red1"))
 
119
    (((class color) (min-colors 8) (background light))
 
120
     (:foreground "red"))
 
121
    (((class color) (min-colors 8) (background dark))
 
122
     )
 
123
    (t (:weight bold :slant italic)))
 
124
  "Face used to highlight text after POD commands"
 
125
  :group 'pod-mode-faces)
 
126
 
 
127
(defface pod-mode-verbatim-face
 
128
  '((((class grayscale) (background light)) (:foreground "Gray90" :weight bold))
 
129
    (((class grayscale) (background dark)) (:foreground "DimGray" :weight bold))
 
130
    (((class color) (min-colors 88) (background light)) (:foreground "ForestGreen"))
 
131
    (((class color) (min-colors 88) (background dark)) (:foreground "PaleGreen"))
 
132
    (((class color) (min-colors 16) (background light)) (:foreground "ForestGreen"))
 
133
    (((class color) (min-colors 16) (background dark)) (:foreground "PaleGreen"))
 
134
    (((class color) (min-colors 8)) (:foreground "green"))
 
135
    (t (:weight bold :underline t)))
 
136
  "Face used to highlight verbatim paragraphs in POD"
 
137
  :group 'pod-mode-faces)
 
138
 
 
139
(defface pod-mode-formatting-code-character-face
 
140
  '((((class grayscale) (background light))
 
141
     (:foreground "Gray90" :weight bold :slant italic))
 
142
    (((class grayscale) (background dark))
 
143
     (:foreground "DimGray" :weight bold :slant italic))
 
144
    (((class color) (min-colors 88) (background light)) (:foreground "sienna"))
 
145
    (((class color) (min-colors 88) (background dark)) (:foreground "LightGoldenrod"))
 
146
    (((class color) (min-colors 16) (background light)) (:foreground "DarkGoldenrod"))
 
147
    (((class color) (min-colors 16) (background dark)) (:foreground "LightGoldenrod"))
 
148
    (((class color) (min-colors 8)) (:foreground "yellow" :weight light))
 
149
    (t (:weight bold :slant italic)))
 
150
  "Face used to highlight formatting codes in POD"
 
151
  :group 'pod-mode-faces)
 
152
 
 
153
(defface pod-mode-formatting-code-face
 
154
  '((((class grayscale) (background light))
 
155
     (:foreground "LightGray" :weight bold :underline t))
 
156
    (((class grayscale) (background dark))
 
157
     (:foreground "Gray50" :weight bold :underline t))
 
158
    (((class color) (min-colors 88) (background light)) (:foreground "dark cyan"))
 
159
    (((class color) (min-colors 88) (background dark)) (:foreground "Aquamarine"))
 
160
    (((class color) (min-colors 16) (background light)) (:foreground "CadetBlue"))
 
161
    (((class color) (min-colors 16) (background dark)) (:foreground "Aquamarine"))
 
162
    (((class color) (min-colors 8)) (:foreground "magenta"))
 
163
    (t (:weight bold :underline t)))
 
164
  "Face used to highlight text within formatting codes in POD"
 
165
  :group 'pod-mode-faces)
 
166
 
 
167
(defface pod-mode-formatting-code-i-face
 
168
  '((t (:inherit pod-mode-formatting-code-face :slant italic)))
 
169
  "Face used to highlight I<> formatting codes in POD"
 
170
  :group 'pod-mode-faces)
 
171
 
 
172
(defface pod-mode-formatting-code-b-face
 
173
  '((t (:inherit pod-mode-formatting-code-face :weight bold)))
 
174
  "Face used to highlight B<> formatting codes in POD"
 
175
  :group 'pod-mode-faces)
 
176
 
 
177
(defface pod-mode-alternative-formatting-code-face
 
178
  '((((class color) (min-colors 88) (background light)) (:foreground "Blue1"))
 
179
    (((class color) (min-colors 88) (background dark)) (:foreground "LightSkyBlue"))
 
180
    (((class color) (min-colors 16) (background light)) (:foreground "Blue"))
 
181
    (((class color) (min-colors 16) (background dark)) (:foreground "LightSkyBlue"))
 
182
    (((class color) (min-colors 8)) (:foreground "blue" :weight bold))
 
183
    (t (:inverse-video t :weight bold)))
 
184
  "Alternative face used to highlight formatting codes in POD.
 
185
This is used for E<> escapes and for the link target in L<>
 
186
escapes."
 
187
  :group 'pod-mode-faces)
 
188
 
 
189
(defface pod-mode-string-face
 
190
  '((((class grayscale) (background light)) (:foreground "DimGray" :slant italic))
 
191
    (((class grayscale) (background dark)) (:foreground "LightGray" :slant italic))
 
192
    (((class color) (min-colors 88) (background light)) (:foreground "VioletRed4"))
 
193
    (((class color) (min-colors 88) (background dark)) (:foreground "LightSalmon"))
 
194
    (((class color) (min-colors 16) (background light)) (:foreground "RosyBrown"))
 
195
    (((class color) (min-colors 16) (background dark)) (:foreground "LightSalmon"))
 
196
    (((class color) (min-colors 8)) (:foreground "green"))
 
197
    (t (:slant italic)))
 
198
  "Face used to highlight quoted strings in POD"
 
199
  :group 'pod-mode-faces)
 
200
 
 
201
(defvar pod-mode-hook nil
 
202
  "List of functions to be called when activating `pod-mode'.")
74
203
 
75
204
;;; Version: 1.01
76
205
(defvar pod-version "1.01"
77
 
  "Version of POD mode")
78
 
 
79
 
;; keymap
80
 
(defvar pod-mode-map nil "Keymap for POD major mode.")
81
 
(if pod-mode-map nil
82
 
  (let ((map (make-sparse-keymap)))
83
 
    ;; insert (define-key map ...) stuff here
84
 
    (setq pod-mode-map map)))
85
 
 
86
 
;; syntax highlighting: standard keywords
87
 
(defconst pod-font-lock-keywords-1
88
 
  '(
89
 
    ("^=\\(head[1234]\\|item\\|over\\|back\\|cut\\|pod\\|for\\|begin\\|end\\|encoding\\)" 0 font-lock-keyword-face)
90
 
    ("^[ \t]+\\(.*\\)$" 1 font-lock-type-face)
91
 
    )
92
 
  "Minimal highlighting expressions for POD mode.")
93
 
 
94
 
;; syntax highlighting: additional keywords
 
206
  "Version of POD mode.")
 
207
 
 
208
(let* ((head-sizes '(1.9 1.7 1.5 1.3))
 
209
       (heads (loop for i from 1 to (length head-sizes) collect
 
210
                    (cons i (nth (- i 1) head-sizes)))))
 
211
  (defconst pod-font-lock-keywords-1
 
212
    (append
 
213
     (loop for (n . s) in heads collect
 
214
           (let ((head-face-name (intern (format "pod-mode-head%d-face" n)))
 
215
                 (text-face-name (intern (format "pod-mode-head%d-text-face" n))))
 
216
             (eval `(defface ,head-face-name
 
217
                      '((t (:inherit pod-mode-head-face :height ,s)))
 
218
                      ,(format "Face used to highlight head%d commands" n)
 
219
                      :group 'pod-mode-faces))
 
220
             (eval `(defface ,text-face-name
 
221
                      '((t (:inherit pod-mode-command-text-face :height ,s)))
 
222
                      ,(format "Face used to hightlight text in head%d commands" n)
 
223
                      :group 'pod-mode-faces))
 
224
             `(,(format "^\\(=head%d\\)\\(.*\\)" n)
 
225
               (1 (quote ,head-face-name))
 
226
               (2 (quote ,text-face-name)))))
 
227
     `((,(format "^\\(=%s\\)\\(.*\\)"
 
228
                 (regexp-opt '("item" "over" "back" "cut" "pod"
 
229
                               "for" "begin" "end" "encoding")))
 
230
        (1 'pod-mode-command-face)
 
231
        (2 'pod-mode-command-text-face))))
 
232
    "Minimal highlighting expressions for POD mode."))
 
233
 
95
234
(defconst pod-font-lock-keywords-2
96
 
  (append pod-font-lock-keywords-1
97
 
          '(
98
 
            ("^=\\(head[1234]\\|item\\|over\\|back\\|cut\\|pod\\|for\\|begin\\|end\\)\\(.*\\)" 2 font-lock-comment-face)
99
 
            ))
 
235
  (append pod-font-lock-keywords-1 '())
100
236
  "Additional Keywords to highlight in POD mode.")
101
237
 
102
 
;; syntax highlighting: even more keywords
 
238
(defun pod-matcher-for-code (code body)
 
239
  "Create a matcher function for a given POD formatting CODE.
 
240
Will return a quoted lambda as expected by `font-lock-keywords'
 
241
as MATCHER.
 
242
 
 
243
When executing the lambda, it will match a POD formatting code
 
244
introduced with the character CODE and as described in perlpod.
 
245
 
 
246
BODY is expected to be a quoted lambda.  It will be executed
 
247
after a successful match of a well-balanced formatting code.
 
248
It'll get two arguments, the start and end position of the text
 
249
contained in the formatting code.  It should return a list of
 
250
positions suitable to use as match data for later highlighting by
 
251
`font-lock-keywords'."
 
252
  `(lambda (limit)
 
253
     (when (re-search-forward
 
254
            ,(concat
 
255
              code
 
256
              "\\(?:\\(?:\\(<\\)[^<]\\)\\|\\(?:\\(<\\{2,\\}\\)\s\\)\\)")
 
257
            limit t)
 
258
       (let ((beg (or (match-end 1)
 
259
                      (match-end 2)))
 
260
             (n-lt (length (or (match-string-no-properties 1)
 
261
                               (match-string-no-properties 2)))))
 
262
         (goto-char (- (point) 1))
 
263
         (when (re-search-forward
 
264
                (concat (when (> n-lt 1) "\s")
 
265
                        "\\("
 
266
                        (apply 'concat (loop for i from 1 to n-lt collect ">"))
 
267
                        "\\)")
 
268
                limit t)
 
269
           (let* ((end (match-beginning 1))
 
270
                  (match-data (funcall ,body beg end)))
 
271
             (when (match-data)
 
272
               (store-match-data (append
 
273
                                  (list (- beg n-lt 1) beg)
 
274
                                  match-data
 
275
                                  (list end (+ end n-lt))))
 
276
               t)))))))
 
277
 
 
278
(defun pod-keyword-for-simple-code (code face)
 
279
  "Build a `font-lock-keywords' keyword for a POD formatting code.
 
280
CODE is the character introducing the formatting code to be
 
281
matched.  FACE is the face that should be used to map the text
 
282
within the formattign code.
 
283
 
 
284
In addition to matching the code's content with FACE, the
 
285
formatting code itself will be highlighted using
 
286
`pod-mode-formatting-code-character-face'."
 
287
  `(,(pod-matcher-for-code code '(lambda (beg end)
 
288
                                   (list beg end)))
 
289
    (0 'pod-mode-formatting-code-character-face prepend)
 
290
    (1 ',face append)
 
291
    (2 'pod-mode-formatting-code-character-face prepend)))
 
292
 
103
293
(defconst pod-font-lock-keywords-3
104
294
  (append pod-font-lock-keywords-2
105
 
          '(
106
 
            ("[IBCFXZS]<\\([^>]*\\)>" 1 font-lock-reference-face)
107
 
            ("L<\\(\\([^|>]*\\)|\\)\\([^>]+\\)>"
108
 
             (2 font-lock-reference-face)
109
 
             (3 font-lock-function-name-face))
110
 
            ("L<\\([^|>]+\\)>" 1 font-lock-function-name-face)
111
 
            ("E<\\([^>]*\\)>" 1 font-lock-function-name-face)
112
 
            ("\"\\([^\"]+\\)\"" 0 font-lock-string-face)
113
 
            ))
 
295
          (loop for code in '("C" "F" "X" "Z" "S")
 
296
                collect (pod-keyword-for-simple-code
 
297
                         code 'pod-mode-formatting-code-face))
 
298
          (list
 
299
           (pod-keyword-for-simple-code
 
300
            "E" 'pod-mode-alternative-formatting-code-face)
 
301
           (pod-keyword-for-simple-code "I" 'pod-mode-formatting-code-i-face)
 
302
           (pod-keyword-for-simple-code "B" 'pod-mode-formatting-code-b-face)
 
303
           `(,(pod-matcher-for-code
 
304
               "L" (lambda (beg end)
 
305
                     (goto-char beg)
 
306
                     (if (re-search-forward "\\([^|]\\)|" end t)
 
307
                         (list beg (match-end 1)
 
308
                               (+ (match-end 1) 1) end)
 
309
                       (list 0 0 beg end))))
 
310
             (0 'pod-mode-formatting-code-character-face prepend)
 
311
             (1 'pod-mode-formatting-code-face append)
 
312
             (2 'pod-mode-alternative-formatting-code-face append)
 
313
             (3 'pod-mode-formatting-code-character-face prepend))
 
314
           '("\"\\([^\"]+\\)\""
 
315
             (0 'pod-mode-string-face))
 
316
           '("^[ \t]+\\(.*\\)$" 1 'pod-mode-verbatim-face prepend)))
114
317
  "Balls-out highlighting in POD mode.")
115
318
 
116
 
;; default level of highlight to maximum
117
319
(defvar pod-font-lock-keywords pod-font-lock-keywords-3
118
 
  "Default highlighting expressions for POD mode")
119
 
 
120
 
;; no special indenting, just pure text mode
121
 
(defun pod-indent-line ()
122
 
  "Indent current line as POD code. Does nothing yet."
123
 
  (interactive)
124
 
  )
125
 
 
126
 
;; no special syntax table
127
 
(defvar pod-mode-syntax-table nil
128
 
  "Syntax table for pod-mode.")
129
 
 
130
 
;; create and activate syntax table
131
 
(defun pod-create-syntax-table ()
132
 
  (if pod-mode-syntax-table
133
 
      ()
134
 
    (setq pod-mode-syntax-table (make-syntax-table))
135
 
    (set-syntax-table pod-mode-syntax-table)
136
 
    ))
137
 
 
138
 
(defun pod-add-support-for-outline-minor-mode ()
139
 
  "Provides additional menus from =head lines in outline-minor-mode"
 
320
  "Default highlighting expressions for POD mode.")
 
321
 
 
322
(defvar pod-weaver-section-keywords nil
 
323
  "List of custom Pod::Weaver keywords describing sections.
 
324
This is an alist, mapping strings with pod commands to a number
 
325
describing their level within the document.")
 
326
(make-local-variable 'pod-weaver-section-keywords)
 
327
 
 
328
(defun pod-linkable-sections-for-buffer (buffer &optional section-keywords)
 
329
  "Extract POD sections from BUFFER.
 
330
Returns a list of POD section names with BUFFER.  By default only
 
331
=head commands are looked for.  The optional second argument
 
332
SECTION-KEYWORDS may be used to also extract section names from
 
333
additional pod commands."
 
334
  (with-current-buffer buffer
 
335
    (save-excursion
 
336
      (save-match-data
 
337
        (goto-char (point-min))
 
338
        (loop while (re-search-forward
 
339
                     (format "^=%s\s+\\(.*\\)$"
 
340
                             (regexp-opt
 
341
                              (append
 
342
                               (loop for i from 1 to 4
 
343
                                     collect (format "head%d" i))
 
344
                               '("item")
 
345
                               section-keywords)))
 
346
                     nil t)
 
347
              collect (match-string-no-properties 1))))))
 
348
 
 
349
(defun pod-linkable-sections-for-module (module)
 
350
  "Extract POD sections from MODULE.
 
351
Opens the documentation of an installed perl MODULE and returns a
 
352
list of all section names in it.
 
353
 
 
354
`pod-linkable-sections-for-buffer' is used to actually extract
 
355
the sections."
 
356
  (with-current-buffer (get-buffer-create (concat "*POD " module "*"))
 
357
    (unwind-protect
 
358
        (progn
 
359
          (kill-all-local-variables)
 
360
          (erase-buffer)
 
361
          (text-mode)
 
362
          (let ((default-directory "/"))
 
363
            (call-process "perldoc" nil (current-buffer) nil "-T" "-u" module)
 
364
            (goto-char (point-min))
 
365
            (when (and (> (count-lines (point-min) (point-max)) 1)
 
366
                       (not (re-search-forward
 
367
                             "No documentation found for .*" nil t)))
 
368
              (pod-linkable-sections-for-buffer (current-buffer)))))
 
369
      (kill-buffer (current-buffer)))))
 
370
 
 
371
(defun pod-linkable-sections (&optional module)
 
372
  "Extract POD sections.
 
373
Extracts all POD sections from either the current buffer, or, if
 
374
MODULE is given, from the POD documentation of an installed
 
375
module.
 
376
 
 
377
If MODULE is given, `pod-linkable-sections-for-module' will be
 
378
called.  Otherwise `pod-linkable-sections-for-buffer' for
 
379
`current-buffer', and with all additional POD section keywords as
 
380
provided by `pod-weaver-section-keywords'."
 
381
  (if module
 
382
      (pod-linkable-sections-for-module module)
 
383
    (pod-linkable-sections-for-buffer
 
384
     (current-buffer)
 
385
     (mapcar (lambda (i) (car i))
 
386
             pod-weaver-section-keywords))))
 
387
 
 
388
(defun pod-linkable-modules (&optional re-cache)
 
389
  "Find all installed perl modules.
 
390
Returns a list of all installed perl modules, as provided by
 
391
function `perldoc-modules-alist'.  This requires `perldoc' to be
 
392
loadable.
 
393
 
 
394
If the optional argument RE-CACHE is non-nil, a possibly cached
 
395
version of the module list will be discarded and rebuilt."
 
396
  (save-current-buffer
 
397
    (when (ignore-errors (require 'perldoc))
 
398
      (when (or re-cache (not perldoc-modules-alist))
 
399
        (message "Building completion list of all perl modules..."))
 
400
      (mapcar (lambda (i) (car i)) (perldoc-modules-alist re-cache)))))
 
401
 
 
402
(defun pod-link (link &optional text)
 
403
  "Insert a POD hyperlink formatting code.
 
404
Inserts a POD L<> formatting code at point.  The content of the
 
405
code will be LINK.
 
406
 
 
407
If the optional argument TEXT is a string and contains anything
 
408
that's not whitespace, it will be used as the link title."
 
409
  (insert (concat "L<"
 
410
                  (when (and (stringp text)
 
411
                             (string-match-p "[^\s]" text))
 
412
                    (concat text "|"))
 
413
                  link
 
414
                  ">")))
 
415
 
 
416
(defun pod-completing-read (prompt choices)
 
417
  "Use `completing-read' to do a completing read."
 
418
  (completing-read prompt choices))
 
419
 
 
420
(defun pod-icompleting-read (prompt choices)
 
421
  "Use iswitchb to do a completing read."
 
422
  (let ((iswitchb-make-buflist-hook
 
423
         (lambda ()
 
424
           (setq iswitchb-temp-buflist choices))))
 
425
    (unwind-protect
 
426
        (progn
 
427
          (when (not iswitchb-mode)
 
428
            (add-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup))
 
429
          (iswitchb-read-buffer prompt))
 
430
      (when (not iswitchb-mode)
 
431
        (remove-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup)))))
 
432
 
 
433
(defun pod-ido-completing-read (prompt choices)
 
434
  "Use ido to do a completing read."
 
435
  (ido-completing-read prompt choices))
 
436
 
 
437
(defcustom pod-completing-read-function
 
438
  #'pod-icompleting-read
 
439
  "Ask the user to select a single item from a list.
 
440
Used by `pod-link-section', `pod-link-module', and
 
441
`pod-link-module-section'."
 
442
  :group 'pod-mode
 
443
  :type '(radio (function-item
 
444
                 :doc "Use Emacs' standard `completing-read' function."
 
445
                 pod-completing-read)
 
446
                (function-item :doc "Use iswitchb's completing-read function."
 
447
                               pod-icompleting-read)
 
448
                (function-item :doc "Use ido's completing-read function."
 
449
                               pod-ido-completing-read)
 
450
                (function)))
 
451
 
 
452
(defun pod-do-completing-read (&rest args)
 
453
  "Do a completing read with the configured `pod-completing-read-function'."
 
454
  (apply pod-completing-read-function args))
 
455
 
 
456
(defun pod-link-uri (uri &optional text)
 
457
  "Insert POD hyperlink formatting code for a URL.
 
458
Calls `pod-link' with URI and TEXT.
 
459
 
 
460
When called interactively, URI and TEXT will be read from the
 
461
minibuffer."
 
462
  (interactive
 
463
   (list (read-string "URI: ")
 
464
         (read-string "Text: ")))
 
465
  (pod-link uri text))
 
466
 
 
467
(defun pod-link-section (section &optional text)
 
468
  "Insert hyperlink formatting code for a POD section.
 
469
Insert an L<> formatting code pointing to a section within the
 
470
current document.
 
471
 
 
472
When called interactively, SECTION and TEXT will be read using
 
473
`pod-do-completing-read'.
 
474
 
 
475
When reading SECTION, `pod-linkable-sections' will be used to
 
476
provide completions."
 
477
  (interactive
 
478
   (list (pod-do-completing-read "Section: " (pod-linkable-sections))
 
479
         (read-string "Text: ")))
 
480
  (pod-link-module-section "" section text))
 
481
 
 
482
(defun pod-link-module (module &optional text)
 
483
  "Insert POD hyperlink formatting code for a module.
 
484
Insert an L<> formatting code pointing to a MODULE.
 
485
 
 
486
When called interactively, MODULE and TEXT will be read using
 
487
`pod-do-completing-read'.
 
488
 
 
489
When reading MODULE, `pod-linkable-modules' will be used to
 
490
provide completions."
 
491
  (interactive
 
492
   (list (pod-do-completing-read "Module: "
 
493
                                 (pod-linkable-modules current-prefix-arg))
 
494
         (read-string "Text: ")))
 
495
  (pod-link module text))
 
496
 
 
497
(defun pod-link-module-section (module section &optional text)
 
498
  "Insert POD hyperlink formatting code for a section in a module.
 
499
Insert an L<> formatting code pointing to a part of MODULE
 
500
documentation as described by SECTION.
 
501
 
 
502
When called interactive, MODULE, SECTION, and TEXT will be read
 
503
using `pod-do-completing-read'.
 
504
 
 
505
When reading MODULE and SECTION, `pod-linkable-modules' and
 
506
`pod-linkable-sections', respectively, will be used to provide
 
507
completions."
 
508
  (interactive
 
509
   (let ((module (pod-do-completing-read
 
510
                  "Module: "
 
511
                  (pod-linkable-modules current-prefix-arg))))
 
512
     (list module
 
513
           (pod-do-completing-read "Section: " (pod-linkable-sections module))
 
514
           (read-string "Text: "))))
 
515
  (pod-link
 
516
   (concat module
 
517
           "/"
 
518
           (if (string-match-p "\s" section)
 
519
               (concat "\"" section "\"")
 
520
             section))
 
521
   text))
 
522
 
 
523
(defvar pod-mode-map
 
524
  (let ((map (make-sparse-keymap)))
 
525
    (define-key map (kbd "C-c C-l u") 'pod-link-uri)
 
526
    (define-key map (kbd "C-c C-l s") 'pod-link-section)
 
527
    (define-key map (kbd "C-c C-l m") 'pod-link-module)
 
528
    (define-key map (kbd "C-c C-l M") 'pod-link-module-section)
 
529
    map)
 
530
  "Keymap for POD major mode.")
 
531
 
 
532
(defvar pod-mode-syntax-table
 
533
  (let ((st (make-syntax-table)))
 
534
    st)
 
535
  "Syntax table for `pod-mode'.")
 
536
 
 
537
(defun pod-add-support-for-outline-minor-mode (&rest sections)
 
538
  "Provides additional menus from section commands for function
 
539
`outline-minor-mode'.
 
540
 
 
541
SECTIONS can be used to supply section commands in addition to
 
542
the POD defaults."
140
543
  (make-local-variable 'outline-regexp)
141
 
  (setq outline-regexp "=head[1234] ")
 
544
  (setq outline-regexp
 
545
        (format "=%s\s"
 
546
         (regexp-opt
 
547
          (append (loop for i from 1 to 4 collect (format "head%d" i))
 
548
                  '("item") sections))))
142
549
  (make-local-variable 'outline-level)
143
550
  (setq outline-level
144
 
        (function (lambda ()
145
 
                    (save-excursion
146
 
                      (string-to-int (buffer-substring (+ (point) 5) (+ (point) 6)))
147
 
                      ))))
148
 
  )
 
551
        (lambda ()
 
552
          (save-excursion
 
553
            (save-match-data
 
554
              (let ((sect (format "^=%s\s"
 
555
                                  (regexp-opt
 
556
                                   (mapcar (lambda (i) (car i))
 
557
                                           pod-weaver-section-keywords) t))))
 
558
                (cond
 
559
                 ((looking-at sect)
 
560
                  (cdr (assoc (match-string-no-properties 1)
 
561
                              pod-weaver-section-keywords)))
 
562
                 ((looking-at "^=item\s") 5)
 
563
                 ((string-to-number (buffer-substring
 
564
                                     (+ (point) 5)
 
565
                                     (+ (point) 6)))))))))))
 
566
 
 
567
(defun pod-add-support-for-imenu (&rest sections)
 
568
  "Set up `imenu-generic-expression' for pod section commands.
 
569
SECTIONS can be used to supply section commands in addition to
 
570
the POD defaults."
 
571
  (setq imenu-generic-expression
 
572
        `((nil ,(format "^=%s\s+\\(.*\\)"
 
573
                        (regexp-opt
 
574
                         (append
 
575
                          (loop for i from 1 to 4 collect (format "head%d" i))
 
576
                          '("item") sections)))
 
577
               1))))
149
578
 
150
579
(defun pod-enable-weaver-collector-keywords (collectors)
151
 
  (let* ((keyword-list (mapcar (lambda (collector)
152
 
                                 (symbol-name (getf collector 'command)))
153
 
                               collectors))
154
 
         (keyword-re (concat "^=" (regexp-opt keyword-list t))))
155
 
    (setf pod-font-lock-keywords
156
 
          (append pod-font-lock-keywords
157
 
                  `((,keyword-re 0 font-lock-keyword-face))
158
 
                  `((,(concat keyword-re "\\(.*\\)") 2 font-lock-comment-face))))
 
580
  "Enable support for Pod::Weaver collector commands.
 
581
Enables fontification for all commands described by COLLECTORS.
 
582
 
 
583
Also updates `pod-weaver-section-keywords', `outline-regexp', and
 
584
`imenu-generic-expression' accordingly."
 
585
  (let ((collectors-by-replacement))
 
586
    (save-match-data
 
587
      (setf pod-weaver-section-keywords
 
588
            (loop for col in collectors
 
589
                  with cmd with new-cmd with new-name
 
590
                  do (progn
 
591
                       (setq cmd (getf col 'command)
 
592
                             new-cmd (getf col 'new_command)
 
593
                             new-name (symbol-name new-cmd))
 
594
                       (let ((pos (loop for i in collectors-by-replacement do
 
595
                                        (when (equal (car i) new-cmd)
 
596
                                          (return i)))))
 
597
                         (if (not pos)
 
598
                             (push (list new-cmd cmd) collectors-by-replacement)
 
599
                           (setcdr (last pos) (list cmd)))))
 
600
                  when (string-match "^head\\([1-4]\\)$" new-name)
 
601
                  collect (cons (symbol-name cmd)
 
602
                                (string-to-number
 
603
                                 (match-string-no-properties 1 new-name)))
 
604
                  when (string-match "^item$" new-name)
 
605
                  collect (cons (symbol-name cmd) 5))))
 
606
    (let ((sections (mapcar (lambda (i) (car i))
 
607
                            pod-weaver-section-keywords)))
 
608
      (apply #'pod-add-support-for-outline-minor-mode sections)
 
609
      (apply #'pod-add-support-for-imenu sections))
 
610
    (setf
 
611
     pod-font-lock-keywords
 
612
     (append
 
613
      (mapcar (lambda (i)
 
614
                (append
 
615
                 (list (format "^\\(=%s\\)\\(.*\\)"
 
616
                               (regexp-opt (mapcar (lambda (k) (symbol-name k))
 
617
                                                   (cdr i)))))
 
618
                 (let ((n (symbol-name (car i))))
 
619
                   (if (string-match-p "^head[1-4]$" n)
 
620
                       (list
 
621
                        `(1 (quote
 
622
                             ,(intern (format "pod-mode-%s-face" n))))
 
623
                        `(2 (quote
 
624
                             ,(intern (format "pod-mode-%s-text-face" n)))))
 
625
                     (list
 
626
                      '(1 'pod-mode-command-face)
 
627
                      '(2 'pod-mode-command-text-face))))))
 
628
              collectors-by-replacement)
 
629
      pod-font-lock-keywords))
159
630
    (setq font-lock-mode-major-mode nil)
160
631
    (font-lock-fontify-buffer)))
161
632
 
162
 
(defun pod-enable-weaver-features (weaver-config)
163
 
  (pod-enable-weaver-collector-keywords (getf weaver-config 'collectors))
164
 
  (message "Pod::Weaver keywords loaded."))
165
 
 
166
 
(defvar pod-weaver-config-buffer "")
 
633
(defun pod-enable-weaver-features (buffer weaver-config)
 
634
  "Enable support for Pod::Weaver features.
 
635
Enables support for custom Pod::Weaver commands within a BUFFER.
 
636
 
 
637
WEAVER-CONFIG is a structure as returned by
 
638
\"dzil weaverconf -f lisp\".
 
639
 
 
640
Currently only supports collector commands via
 
641
`pod-enable-weaver-collector-keywords'."
 
642
  (with-current-buffer buffer
 
643
    (pod-enable-weaver-collector-keywords (getf weaver-config 'collectors))
 
644
    (message "Pod::Weaver keywords loaded.")))
167
645
 
168
646
(defun pod-load-weaver-config (dir)
169
 
  "Load additional pod keywords from a projects dist.ini/weaver.ini"
 
647
  "Load additional pod keywords from dist.ini/weaver.ini in DIR."
170
648
  (let* ((proc (start-process-shell-command
171
649
                (concat "weaverconf-" (buffer-name (current-buffer)))
172
650
                nil (format "cd %s; dzil weaverconf -f lisp" dir))))
173
 
    (make-local-variable 'pod-weaver-config-buffer)
 
651
    (set-process-plist proc (list :buffer (current-buffer)
 
652
                                  :output ""))
174
653
    (set-process-filter
175
654
     proc (lambda (proc str)
176
 
            (setq pod-weaver-config-buffer (concat pod-weaver-config-buffer str))))
 
655
            (let ((plist (process-plist proc)))
 
656
              (plist-put plist :output (concat (plist-get plist :output) str)))))
177
657
    (set-process-sentinel
178
658
     proc (lambda (proc event)
179
659
            (if (string-equal event "finished\n")
180
 
                (let ((weaver-config
181
 
                       (ignore-errors
182
 
                         (eval (car (read-from-string pod-weaver-config-buffer))))))
183
 
                  (if weaver-config (pod-enable-weaver-features weaver-config))))
184
 
            (setq pod-weaver-config-buffer "")))))
 
660
                (let* ((plist (process-plist proc))
 
661
                       (weaver-config
 
662
                        (ignore-errors
 
663
                          (eval (car (read-from-string
 
664
                                      (plist-get plist :output)))))))
 
665
                  (if weaver-config (pod-enable-weaver-features
 
666
                                     (plist-get (process-plist proc) :buffer)
 
667
                                     weaver-config))))))))
185
668
 
186
669
(defun pod-add-support-for-weaver ()
 
670
  "Enable support for Pod::Weaver features in the current buffer.
 
671
Calls `pod-load-weaver-config' with the project directory of the
 
672
current buffer's file.  To be able to successfully determine the
 
673
project directory, `eproject-maybe-turn-on' will be used and
 
674
'eproject.el' is expected to be loaded.
 
675
 
 
676
Does nothing if finding the project directory fails."
187
677
  (let ((project-root (ignore-errors (eproject-maybe-turn-on))))
188
678
    (if project-root (pod-load-weaver-config project-root))))
189
679
 
190
 
;; main
 
680
;;;###autoload
191
681
(defun pod-mode ()
192
 
  "Major mode for editing POD files (Plain Old Documentation for Perl)."
 
682
  "Major mode for editing POD files (Plain Old Documentation for Perl).
 
683
 
 
684
Commands:\\<pod-mode-map>
 
685
\\[pod-link]  `pod-link'
 
686
\\[pod-link-section]     `pod-link-section'
 
687
\\[pod-link-module]     `pod-link-module'
 
688
\\[pod-link-module-section]     `pod-link-module-section'
 
689
 
 
690
Turning on pod mode calls the hooks in `pod-mode-hook'."
193
691
  (interactive)
194
692
  (kill-all-local-variables)
195
 
  (pod-create-syntax-table)
 
693
  (set-syntax-table pod-mode-syntax-table)
196
694
  (use-local-map pod-mode-map)
197
695
  (make-local-variable 'font-lock-defaults)
198
696
  (setq font-lock-defaults '(pod-font-lock-keywords 't))
199
 
  ;; (make-local-variable 'indent-line-function)
200
 
  ;; (setq indent-line-function 'pod-indent-line)
201
697
  (setq major-mode 'pod-mode)
202
698
  (setq mode-name "POD")
203
 
  (setq imenu-generic-expression '((nil "^=head[1234] +\\(.*\\)" 1)))
 
699
  (pod-add-support-for-imenu)
 
700
  (pod-add-support-for-outline-minor-mode)
204
701
  (run-hooks 'pod-mode-hook)
205
 
  (pod-add-support-for-outline-minor-mode)
206
 
  (pod-add-support-for-weaver)
207
 
  )
 
702
  (pod-add-support-for-weaver))
208
703
 
209
704
(provide 'pod-mode)
210
705