--- /dev/null
+;;; bibtex.el --- BibTeX mode for GNU Emacs
+
+;; Copyright (C) 1992, 1994, 1995, 1996, 1997, 1998, 1999 Free Software Foundation, Inc.
+
+;; Author: Stefan Schoef <schoef@offis.uni-oldenburg.de>
+;; Bengt Martensson <bengt@mathematik.uni-Bremen.de>
+;; Mark Shapiro <shapiro@corto.inria.fr>
+;; Mike Newton <newton@gumby.cs.caltech.edu>
+;; Aaron Larson <alarson@src.honeywell.com>
+;; Maintainer: none
+;; Keywords: BibTeX, LaTeX, TeX
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; Major mode for editing and validating BibTeX files.
+
+;; Usage:
+;; See documentation for function bibtex-mode (or type "\M-x describe-mode"
+;; when you are in BibTeX mode).
+
+;; Todo:
+;; Distribute texinfo file.
+
+;;; Code:
+
+(eval-when-compile
+ (require 'compile))
+
+\f
+;; Bug Reporting
+
+(defconst
+ bibtex-maintainer-address "Dirk Herrmann <D.Herrmann@tu-bs.de>")
+;; current maintainer
+
+(defconst
+ bibtex-maintainer-salutation "Hallo Dirk,")
+;; current maintainer
+
+(defconst
+ bibtex-version "(emacs 20.4)")
+;; current version of the bibtex.el file
+
+\f
+;; User Options:
+
+(defgroup bibtex nil
+ "BibTeX mode."
+ :group 'tex
+ :prefix "bibtex-")
+
+(defgroup bibtex-autokey nil
+ "Generates automatically a key from the author/editor and the title field"
+ :group 'bibtex
+ :prefix "bibtex-autokey-")
+
+(defcustom bibtex-mode-hook nil
+ "List of functions to call on entry to BibTeX mode."
+ :group 'bibtex
+ :type 'hook)
+
+(defcustom bibtex-field-delimiters 'braces
+ "*Controls type of field delimiters used.
+Set this to `braces' or `double-quotes' according to your personal
+preferences. This variable is buffer-local."
+ :group 'bibtex
+ :type '(choice (const braces)
+ (const double-quotes)))
+(make-variable-buffer-local 'bibtex-field-delimiters)
+
+(defcustom bibtex-entry-delimiters 'braces
+ "*Controls type of entry delimiters used.
+Set this to `braces' or `parentheses' according to your personal
+preferences. This variable is buffer-local."
+ :group 'bibtex
+ :type '(choice (const braces)
+ (const parentheses)))
+(make-variable-buffer-local 'bibtex-entry-delimiters)
+
+(defcustom bibtex-include-OPTcrossref '("InProceedings" "InCollection")
+ "*All entries listed here will have an OPTcrossref field."
+ :group 'bibtex
+ :type '(repeat string))
+
+(defcustom bibtex-include-OPTkey t
+ "*If non-nil, all entries will have an OPTkey field.
+If this is a string, it will be used as the initial field text.
+If this is a function, it will be called to generate the initial field text."
+ :group 'bibtex
+ :type '(choice (const :tag "None" nil)
+ (string :tag "Initial text")
+ (function :tag "Initialize Function" :value fun)
+ (other :tag "Default" t)))
+
+(defcustom bibtex-user-optional-fields
+ '(("annote" "Personal annotation (ignored)"))
+ "*List of optional fields the user wants to have always present.
+Entries should be of the same form as the OPTIONAL and
+CROSSREF-OPTIONAL lists in `bibtex-entry-field-alist' (see documentation
+of this variable for details)."
+ :group 'bibtex
+ :type '(repeat
+ (group (string :tag "Field")
+ (string :tag "Comment")
+ (option (group :inline t
+ :extra-offset -4
+ (choice :tag "Init" :value ""
+ string
+ function))))))
+
+(defcustom bibtex-entry-format '(opts-or-alts numerical-fields)
+ "*Controls type of formatting performed by `bibtex-clean-entry'.
+It may be t, nil, or a list of symbols out of the following:
+opts-or-alts Delete empty optional and alternative fields and
+ remove OPT and ALT prefixes from used fields.
+numerical-fields Delete delimiters around numeral fields.
+page-dashes Change double dashes in page field to single dash
+ (for scribe compatibility).
+inherit-booktitle If entry contains a crossref field and booktitle
+ field is empty, it is set to the contents of the
+ title field of the crossreferenced entry.
+ Caution: this will work only if buffer is
+ correctly sorted.
+realign Realign entries, so that field texts and perhaps equal
+ signs (depending on the value of
+ `bibtex-align-at-equal-sign') begin in the same column.
+last-comma Add or delete comma on end of last field in entry,
+ according to value of `bibtex-comma-after-last-field'.
+delimiters Change delimiters according to variables
+ `bibtex-field-delimiters' and `bibtex-entry-delimiters'.
+unify-case Change case of entry and field names.
+
+The value t means do all of the above formatting actions.
+The value nil means do no formatting at all."
+ :group 'bibtex
+ :type '(choice (const :tag "None" nil)
+ (const :tag "All" t)
+ (set :menu-tag "Some"
+ (const opts-or-alts)
+ (const numerical-fields)
+ (const page-dashes)
+ (const inherit-booktitle)
+ (const realign)
+ (const last-comma)
+ (const delimiters)
+ (const unify-case))))
+
+(defcustom bibtex-clean-entry-hook nil
+ "*List of functions to call when entry has been cleaned.
+Functions are called with point inside the cleaned entry, and the buffer
+narrowed to just the entry."
+ :group 'bibtex
+ :type 'hook)
+
+(defcustom bibtex-sort-ignore-string-entries t
+ "*If non-nil, BibTeX @String entries are not sort-significant.
+That means they are ignored when determining ordering of the buffer
+(e.g., sorting, locating alphabetical position for new entries, etc.).
+This variable is buffer-local."
+ :group 'bibtex
+ :type 'boolean)
+(make-variable-buffer-local 'bibtex-sort-ignore-string-entries)
+
+(defcustom bibtex-maintain-sorted-entries nil
+ "*If non-nil, BibTeX mode maintains all BibTeX entries in sorted order.
+Setting this variable to nil will strip off some comfort (e.g., TAB
+completion for reference keys in minibuffer, automatic detection of
+duplicates) from BibTeX mode. See also `bibtex-sort-ignore-string-entries'.
+This variable is buffer-local."
+ :group 'bibtex
+ :type 'boolean)
+(make-variable-buffer-local 'bibtex-maintain-sorted-entries)
+
+(defcustom bibtex-field-kill-ring-max 20
+ "*Max length of `bibtex-field-kill-ring' before discarding oldest elements."
+ :group 'bibtex
+ :type 'integer)
+
+(defcustom bibtex-entry-kill-ring-max 20
+ "*Max length of `bibtex-entry-kill-ring' before discarding oldest elements."
+ :group 'bibtex
+ :type 'integer)
+
+(defcustom bibtex-parse-keys-timeout 60
+ "*Specifies interval for parsing buffers.
+All BibTeX buffers in Emacs are parsed if Emacs has been idle
+`bibtex-parse-keys-timeout' seconds. Only buffers which were modified
+after last parsing and which are maintained in sorted order are parsed."
+ :group 'bibtex
+ :type 'integer)
+
+(defvar bibtex-entry-field-alist
+ '(
+ ("Article" . (((("author" "Author1 [and Author2 ...] [and others]")
+ ("title" "Title of the article (BibTeX converts it to lowercase)")
+ ("journal" "Name of the journal (use string, remove braces)")
+ ("year" "Year of publication"))
+ (("volume" "Volume of the journal")
+ ("number" "Number of the journal (only allowed if entry contains volume)")
+ ("pages" "Pages in the journal")
+ ("month" "Month of the publication as a string (remove braces)")
+ ("note" "Remarks to be put at the end of the \\bibitem")
+ ("abstract" "Abstract of the publication")))
+ ((("author" "Author1 [and Author2 ...] [and others]")
+ ("title" "Title of the article (BibTeX converts it to lowercase)"))
+ (("pages" "Pages in the journal")
+ ("journal" "Name of the journal (use string, remove braces)")
+ ("year" "Year of publication")
+ ("volume" "Volume of the journal")
+ ("number" "Number of the journal")
+ ("month" "Month of the publication as a string (remove braces)")
+ ("note" "Remarks to be put at the end of the \\bibitem")
+ ("abstract" "Abstract of the publication")))))
+ ("Book" . (((("author" "Author1 [and Author2 ...] [and others]" "" t)
+ ("editor" "Editor1 [and Editor2 ...] [and others]" "" t)
+ ("title" "Title of the book")
+ ("publisher" "Publishing company")
+ ("year" "Year of publication"))
+ (("volume" "Volume of the book in the series")
+ ("number" "Number of the book in a small series (overwritten by volume)")
+ ("series" "Series in which the book appeared")
+ ("address" "Address of the publisher")
+ ("edition" "Edition of the book as a capitalized English word")
+ ("month" "Month of the publication as a string (remove braces)")
+ ("note" "Remarks to be put at the end of the \\bibitem")))
+ ((("author" "Author1 [and Author2 ...] [and others]" "" t)
+ ("editor" "Editor1 [and Editor2 ...] [and others]" "" t)
+ ("title" "Title of the book"))
+ (("publisher" "Publishing company")
+ ("year" "Year of publication")
+ ("volume" "Volume of the book in the series")
+ ("number" "Number of the book in a small series (overwritten by volume)")
+ ("series" "Series in which the book appeared")
+ ("address" "Address of the publisher")
+ ("edition" "Edition of the book as a capitalized English word")
+ ("month" "Month of the publication as a string (remove braces)")
+ ("note" "Remarks to be put at the end of the \\bibitem")))))
+ ("Booklet" . (((("title" "Title of the booklet (BibTeX converts it to lowercase)"))
+ (("author" "Author1 [and Author2 ...] [and others]")
+ ("howpublished" "The way in which the booklet was published")
+ ("address" "Address of the publisher")
+ ("month" "Month of the publication as a string (remove braces)")
+ ("year" "Year of publication")
+ ("note" "Remarks to be put at the end of the \\bibitem")))))
+ ("InBook" . (((("author" "Author1 [and Author2 ...] [and others]" "" t)
+ ("editor" "Editor1 [and Editor2 ...] [and others]" "" t)
+ ("title" "Title of the book")
+ ("chapter" "Chapter in the book")
+ ("publisher" "Publishing company")
+ ("year" "Year of publication"))
+ (("volume" "Volume of the book in the series")
+ ("number" "Number of the book in a small series (overwritten by volume)")
+ ("series" "Series in which the book appeared")
+ ("type" "Word to use instead of \"chapter\"")
+ ("address" "Address of the publisher")
+ ("edition" "Edition of the book as a capitalized English word")
+ ("month" "Month of the publication as a string (remove braces)")
+ ("pages" "Pages in the book")
+ ("note" "Remarks to be put at the end of the \\bibitem")))
+ ((("author" "Author1 [and Author2 ...] [and others]" "" t)
+ ("editor" "Editor1 [and Editor2 ...] [and others]" "" t)
+ ("title" "Title of the book")
+ ("chapter" "Chapter in the book"))
+ (("pages" "Pages in the book")
+ ("publisher" "Publishing company")
+ ("year" "Year of publication")
+ ("volume" "Volume of the book in the series")
+ ("number" "Number of the book in a small series (overwritten by volume)")
+ ("series" "Series in which the book appeared")
+ ("type" "Word to use instead of \"chapter\"")
+ ("address" "Address of the publisher")
+ ("edition" "Edition of the book as a capitalized English word")
+ ("month" "Month of the publication as a string (remove braces)")
+ ("note" "Remarks to be put at the end of the \\bibitem")))))
+ ("InCollection" . (((("author" "Author1 [and Author2 ...] [and others]")
+ ("title" "Title of the article in book (BibTeX converts it to lowercase)")
+ ("booktitle" "Name of the book")
+ ("publisher" "Publishing company")
+ ("year" "Year of publication"))
+ (("editor" "Editor1 [and Editor2 ...] [and others]")
+ ("volume" "Volume of the book in the series")
+ ("number" "Number of the book in a small series (overwritten by volume)")
+ ("series" "Series in which the book appeared")
+ ("type" "Word to use instead of \"chapter\"")
+ ("chapter" "Chapter in the book")
+ ("pages" "Pages in the book")
+ ("address" "Address of the publisher")
+ ("edition" "Edition of the book as a capitalized English word")
+ ("month" "Month of the publication as a string (remove braces)")
+ ("note" "Remarks to be put at the end of the \\bibitem")))
+ ((("author" "Author1 [and Author2 ...] [and others]")
+ ("title" "Title of the article in book (BibTeX converts it to lowercase)")
+ ("booktitle" "Name of the book"))
+ (("pages" "Pages in the book")
+ ("publisher" "Publishing company")
+ ("year" "Year of publication")
+ ("editor" "Editor1 [and Editor2 ...] [and others]")
+ ("volume" "Volume of the book in the series")
+ ("number" "Number of the book in a small series (overwritten by volume)")
+ ("series" "Series in which the book appeared")
+ ("type" "Word to use instead of \"chapter\"")
+ ("chapter" "Chapter in the book")
+ ("address" "Address of the publisher")
+ ("edition" "Edition of the book as a capitalized English word")
+ ("month" "Month of the publication as a string (remove braces)")
+ ("note" "Remarks to be put at the end of the \\bibitem")))))
+ ("InProceedings" . (((("author" "Author1 [and Author2 ...] [and others]")
+ ("title" "Title of the article in proceedings (BibTeX converts it to lowercase)")
+ ("booktitle" "Name of the conference proceedings")
+ ("year" "Year of publication"))
+ (("editor" "Editor1 [and Editor2 ...] [and others]")
+ ("volume" "Volume of the conference proceedings in the series")
+ ("number" "Number of the conference proceedings in a small series (overwritten by volume)")
+ ("series" "Series in which the conference proceedings appeared")
+ ("pages" "Pages in the conference proceedings")
+ ("address" "Location of the Proceedings")
+ ("month" "Month of the publication as a string (remove braces)")
+ ("organization" "Sponsoring organization of the conference")
+ ("publisher" "Publishing company, its location")
+ ("note" "Remarks to be put at the end of the \\bibitem")))
+ ((("author" "Author1 [and Author2 ...] [and others]")
+ ("title" "Title of the article in proceedings (BibTeX converts it to lowercase)"))
+ (("booktitle" "Name of the conference proceedings")
+ ("pages" "Pages in the conference proceedings")
+ ("year" "Year of publication")
+ ("editor" "Editor1 [and Editor2 ...] [and others]")
+ ("volume" "Volume of the conference proceedings in the series")
+ ("number" "Number of the conference proceedings in a small series (overwritten by volume)")
+ ("series" "Series in which the conference proceedings appeared")
+ ("address" "Location of the Proceedings")
+ ("month" "Month of the publication as a string (remove braces)")
+ ("organization" "Sponsoring organization of the conference")
+ ("publisher" "Publishing company, its location")
+ ("note" "Remarks to be put at the end of the \\bibitem")))))
+ ("Manual" . (((("title" "Title of the manual"))
+ (("author" "Author1 [and Author2 ...] [and others]")
+ ("organization" "Publishing organization of the manual")
+ ("address" "Address of the organization")
+ ("edition" "Edition of the manual as a capitalized English word")
+ ("month" "Month of the publication as a string (remove braces)")
+ ("year" "Year of publication")
+ ("note" "Remarks to be put at the end of the \\bibitem")))))
+ ("MastersThesis" . (((("author" "Author1 [and Author2 ...] [and others]")
+ ("title" "Title of the master\'s thesis (BibTeX converts it to lowercase)")
+ ("school" "School where the master\'s thesis was written")
+ ("year" "Year of publication"))
+ (("type" "Type of the master\'s thesis (if other than \"Master\'s thesis\")")
+ ("address" "Address of the school (if not part of field \"school\") or country")
+ ("month" "Month of the publication as a string (remove braces)")
+ ("note" "Remarks to be put at the end of the \\bibitem")))))
+ ("Misc" . ((()
+ (("author" "Author1 [and Author2 ...] [and others]")
+ ("title" "Title of the work (BibTeX converts it to lowercase)")
+ ("howpublished" "The way in which the work was published")
+ ("month" "Month of the publication as a string (remove braces)")
+ ("year" "Year of publication")
+ ("note" "Remarks to be put at the end of the \\bibitem")))))
+ ("PhdThesis" . (((("author" "Author1 [and Author2 ...] [and others]")
+ ("title" "Title of the PhD. thesis")
+ ("school" "School where the PhD. thesis was written")
+ ("year" "Year of publication"))
+ (("type" "Type of the PhD. thesis")
+ ("address" "Address of the school (if not part of field \"school\") or country")
+ ("month" "Month of the publication as a string (remove braces)")
+ ("note" "Remarks to be put at the end of the \\bibitem")))))
+ ("Proceedings" . (((("title" "Title of the conference proceedings")
+ ("year" "Year of publication"))
+ (("booktitle" "Title of the proceedings for cross references")
+ ("editor" "Editor1 [and Editor2 ...] [and others]")
+ ("volume" "Volume of the conference proceedings in the series")
+ ("number" "Number of the conference proceedings in a small series (overwritten by volume)")
+ ("series" "Series in which the conference proceedings appeared")
+ ("address" "Location of the Proceedings")
+ ("month" "Month of the publication as a string (remove braces)")
+ ("organization" "Sponsoring organization of the conference")
+ ("publisher" "Publishing company, its location")
+ ("note" "Remarks to be put at the end of the \\bibitem")))))
+ ("TechReport" . (((("author" "Author1 [and Author2 ...] [and others]")
+ ("title" "Title of the technical report (BibTeX converts it to lowercase)")
+ ("institution" "Sponsoring institution of the report")
+ ("year" "Year of publication"))
+ (("type" "Type of the report (if other than \"technical report\")")
+ ("number" "Number of the technical report")
+ ("address" "Address of the institution (if not part of field \"institution\") or country")
+ ("month" "Month of the publication as a string (remove braces)")
+ ("note" "Remarks to be put at the end of the \\bibitem")))))
+ ("Unpublished" . (((("author" "Author1 [and Author2 ...] [and others]")
+ ("title" "Title of the unpublished work (BibTeX converts it to lowercase)")
+ ("note" "Remarks to be put at the end of the \\bibitem"))
+ (("month" "Month of the publication as a string (remove braces)")
+ ("year" "Year of publication")))))
+ )
+
+ "Defines entry types and their associated fields.
+List of
+(ENTRY-NAME (REQUIRED OPTIONAL) (CROSSREF-REQUIRED CROSSREF-OPTIONAL))
+triples.
+If the third element is nil, the first pair is always used.
+If not, the second pair is used in the case of presence of a crossref
+field and the third in the case of absence.
+REQUIRED, OPTIONAL, CROSSREF-REQUIRED and CROSSREF-OPTIONAL are lists.
+Each element of these lists is a list of the form
+(FIELD-NAME COMMENT-STRING INIT ALTERNATIVE-FLAG).
+COMMENT-STRING, INIT, and ALTERNATIVE-FLAG are optional.
+FIELD-NAME is the name of the field, COMMENT-STRING the comment to
+appear in the echo area, INIT is either the initial content of the
+field or a function, which is called to determine the initial content
+of the field, and ALTERNATIVE-FLAG (either nil or t) marks if the
+field is an alternative. ALTERNATIVE-FLAG may be t only in the
+REQUIRED or CROSSREF-REQUIRED lists.")
+
+(defvar bibtex-comment-start "@Comment ")
+
+(defcustom bibtex-add-entry-hook nil
+ "List of functions to call when entry has been inserted."
+ :group 'bibtex
+ :type 'hook)
+
+(defcustom bibtex-predefined-month-strings
+ '(
+ ("jan") ("feb") ("mar") ("apr") ("may") ("jun")
+ ("jul") ("aug") ("sep") ("oct") ("nov") ("dec")
+ )
+ "Alist of month string definitions.
+Should contain all strings used for months in the BibTeX style files.
+Each element is a list with just one element: the string."
+ :group 'bibtex
+ :type '(repeat
+ (list string)))
+
+(defcustom bibtex-predefined-strings
+ (append
+ bibtex-predefined-month-strings
+ '(
+ ("acmcs") ("acta") ("cacm") ("ibmjrd") ("ibmsj") ("ieeese")
+ ("ieeetc") ("ieeetcad") ("ipl") ("jacm") ("jcss") ("scp")
+ ("sicomp") ("tcs") ("tocs") ("tods") ("tog") ("toms") ("toois")
+ ("toplas")
+ ))
+ "Alist of string definitions.
+Should contain the strings defined in the BibTeX style files. Each
+element is a list with just one element: the string."
+ :group 'bibtex
+ :type '(repeat
+ (list string)))
+
+(defcustom bibtex-string-files nil
+ "*List of BibTeX files containing string definitions.
+Those files must be specified using pathnames relative to the
+directories specified in `bibtex-string-file-path'. This variable is only
+evaluated when BibTeX mode is entered (i.e., when loading the BibTeX
+file)."
+ :group 'bibtex
+ :type '(repeat file))
+
+(defvar bibtex-string-file-path (getenv "BIBINPUTS")
+ "*Colon separated list of paths to search for `bibtex-string-files'.")
+
+(defcustom bibtex-help-message t
+ "*If not nil print help messages in the echo area on entering a new field."
+ :group 'bibtex
+ :type 'boolean)
+
+(defcustom bibtex-autokey-prefix-string ""
+ "*String to use as a prefix for all generated keys.
+See the documentation of function `bibtex-generate-autokey' for more detail."
+ :group 'bibtex-autokey
+ :type 'string)
+
+(defcustom bibtex-autokey-names 1
+ "*Number of names to use for the automatically generated reference key.
+If this is variable is nil, all names are used.
+Possibly more names are used according to `bibtex-autokey-names-stretch'.
+See the documentation of function `bibtex-generate-autokey' for more detail."
+ :group 'bibtex-autokey
+ :type '(choice (const :tag "All" infty)
+ integer))
+
+(defcustom bibtex-autokey-names-stretch 0
+ "*Number of names that can additionally be used.
+These names are used only, if all names are used then.
+See the documentation of function `bibtex-generate-autokey' for details."
+ :group 'bibtex-autokey
+ :type 'integer)
+
+(defcustom bibtex-autokey-additional-names ""
+ "*String to prepend to the generated key if not all names could be used.
+See the documentation of function `bibtex-generate-autokey' for details."
+ :group 'bibtex-autokey
+ :type 'string)
+
+(defvar bibtex-autokey-transcriptions
+ '(
+ ;; language specific characters
+ ("\\\\aa" "a")
+ ("\\\\AA" "A")
+ ("\\\"a\\|\\\\\\\"a\\|\\\\ae" "ae")
+ ("\\\"A\\|\\\\\\\"A\\|\\\\AE" "Ae")
+ ("\\\\i" "i")
+ ("\\\\j" "j")
+ ("\\\\l" "l")
+ ("\\\\L" "L")
+ ("\\\"o\\|\\\\\\\"o\\|\\\\o\\|\\\\oe" "oe")
+ ("\\\"O\\|\\\\\\\"O\\|\\\\O\\|\\\\OE" "Oe")
+ ("\\\"s\\|\\\\\\\"s" "ss")
+ ("\\\"u\\|\\\\\\\"u" "ue")
+ ("\\\"U\\|\\\\\\\"U" "Ue")
+ ;; accents
+ ("\\\\`\\|\\\\'\\|\\\\\\^\\|\\\\~\\|\\\\=\\|\\\\\\.\\|\\\\u\\|\\\\v\\|\\\\H\\|\\\\t\\|\\\\c\\|\\\\d\\|\\\\b" "")
+ ;; braces
+ ("{" "") ("}" ""))
+ "Alist of (old-regexp new-string) pairs.
+Used by the default values of `bibtex-autokey-name-change-strings' and
+`bibtex-autokey-titleword-change-strings'. Defaults to translating some
+language specific characters to their ASCII transcriptions, and
+removing any character accents.")
+
+(defcustom bibtex-autokey-name-change-strings
+ bibtex-autokey-transcriptions
+ "Alist of (OLD-REGEXP NEW-STRING) pairs.
+Any part of name matching a OLD-REGEXP is replaced by NEW-STRING.
+Case is significant in OLD-REGEXP. All regexps are tried in the
+order in which they appear in the list, so be sure to avoid inifinite
+loops here.
+See the documentation of function `bibtex-generate-autokey' for details."
+ :group 'bibtex-autokey
+ :type '(repeat
+ (list (regexp :tag "Old")
+ (string :tag "New"))))
+
+(defcustom bibtex-autokey-name-case-convert 'downcase
+ "*Function called for each name to perform case conversion.
+See the documentation of function `bibtex-generate-autokey' for more detail."
+ :group 'bibtex-autokey
+ :type '(choice (const :tag "Preserve case" identity)
+ (const :tag "Downcase" downcase)
+ (const :tag "Capitalize" capitalize)
+ (const :tag "Upcase" upcase)
+ (function :tag "Conversion function")))
+
+(defcustom bibtex-autokey-name-length 'infty
+ "*Number of characters from name to incorporate into key.
+If this is set to anything but a number, all characters are used.
+See the documentation of function `bibtex-generate-autokey' for details."
+ :group 'bibtex-autokey
+ :type '(choice (const :tag "All" infty)
+ integer))
+
+(defcustom bibtex-autokey-name-separator ""
+ "*String that comes between any two names in the key.
+See the documentation of function `bibtex-generate-autokey' for details."
+ :group 'bibtex-autokey
+ :type 'string)
+
+(defcustom bibtex-autokey-year-length 2
+ "*Number of rightmost digits from the year field to incorporate into key.
+See the documentation of function `bibtex-generate-autokey' for details."
+ :group 'bibtex-autokey
+ :type 'integer)
+
+(defcustom bibtex-autokey-year-use-crossref-entry t
+ "*If non-nil use year field from crossreferenced entry if necessary.
+If this variable is non-nil and the current entry has no year, but a
+valid crossref entry, the year field from the crossreferenced entry is
+used.
+See the documentation of function `bibtex-generate-autokey' for details."
+ :group 'bibtex-autokey
+ :type 'boolean)
+
+(defcustom bibtex-autokey-titlewords 5
+ "*Number of title words to use for the automatically generated reference key.
+If this is set to anything but a number, all title words are used.
+Possibly more words from the title are used according to
+`bibtex-autokey-titlewords-stretch'.
+See the documentation of function `bibtex-generate-autokey' for details."
+ :group 'bibtex-autokey
+ :type '(choice (const :tag "All" infty)
+ integer))
+
+(defcustom bibtex-autokey-title-terminators
+ '("\\." "!" "\\?" ":" ";" "--")
+ "*Regexp list defining the termination of the main part of the title.
+Case of the regexps is ignored.
+See the documentation of function `bibtex-generate-autokey' for details."
+ :group 'bibtex-autokey
+ :type '(repeat regexp))
+
+(defcustom bibtex-autokey-titlewords-stretch 2
+ "*Number of words that can additionally be used from the title.
+These words are used only, if a sentence from the title can be ended then.
+See the documentation of function `bibtex-generate-autokey' for details."
+ :group 'bibtex-autokey
+ :type 'integer)
+
+(defcustom bibtex-autokey-titleword-ignore
+ '("A" "An" "On" "The" "Eine?" "Der" "Die" "Das"
+ "[^A-Z].*" ".*[^a-zA-Z0-9].*")
+ "*Determines words from the title that are not to be used in the key.
+Each item of the list is a regexp. If a word of the title matchs a
+regexp from that list, it is not included in the title part of the key.
+See the documentation of function `bibtex-generate-autokey' for details."
+ :group 'bibtex-autokey
+ :type '(repeat regexp))
+
+(defcustom bibtex-autokey-titleword-case-convert 'downcase
+ "*Function called for each titleword to perform case conversion.
+See the documentation of function `bibtex-generate-autokey' for more detail."
+ :group 'bibtex-autokey
+ :type '(choice (const :tag "Preserve case" identity)
+ (const :tag "Downcase" downcase)
+ (const :tag "Capitalize" capitalize)
+ (const :tag "Upcase" upcase)
+ (function :tag "Conversion function")))
+
+(defcustom bibtex-autokey-titleword-abbrevs nil
+ "*Determines exceptions to the usual abbreviation mechanism.
+An alist of (OLD-REGEXP NEW-STRING) pairs. Case is ignored
+in matching against OLD-REGEXP, and the first matching pair is used.
+See the documentation of function `bibtex-generate-autokey' for details.")
+
+(defcustom bibtex-autokey-titleword-change-strings
+ bibtex-autokey-transcriptions
+ "Alist of (OLD-REGEXP NEW-STRING) pairs.
+Any part of title word matching a OLD-REGEXP is replaced by NEW-STRING.
+Case is significant in OLD-REGEXP. All regexps are tried in the
+order in which they appear in the list, so be sure to avoid inifinite
+loops here.
+See the documentation of function `bibtex-generate-autokey' for details."
+ :group 'bibtex-autokey
+ :type '(repeat
+ (list (regexp :tag "Old")
+ (string :tag "New"))))
+
+(defcustom bibtex-autokey-titleword-length 5
+ "*Number of characters from title words to incorporate into key.
+If this is set to anything but a number, all characters are used.
+See the documentation of function `bibtex-generate-autokey' for details."
+ :group 'bibtex-autokey
+ :type '(choice (const :tag "All" infty)
+ integer))
+
+(defcustom bibtex-autokey-titleword-separator "_"
+ "*String to be put between the title words.
+See the documentation of function `bibtex-generate-autokey' for details."
+ :group 'bibtex-autokey
+ :type 'string)
+
+(defcustom bibtex-autokey-name-year-separator ""
+ "*String to be put between name part and year part of key.
+See the documentation of function `bibtex-generate-autokey' for details."
+ :group 'bibtex-autokey
+ :type 'string)
+
+(defcustom bibtex-autokey-year-title-separator ":_"
+ "*String to be put between name part and year part of key.
+See the documentation of function `bibtex-generate-autokey' for details."
+ :group 'bibtex-autokey
+ :type 'string)
+
+(defcustom bibtex-autokey-edit-before-use t
+ "*If non-nil, user is allowed to edit the generated key before it is used."
+ :group 'bibtex-autokey
+ :type 'boolean)
+
+(defcustom bibtex-autokey-before-presentation-function nil
+ "Function to call before the generated key is presented.
+If non-nil this should be a single function, which is called before
+the generated key is presented (in entry or, if
+`bibtex-autokey-edit-before-use' is t, in minibuffer). This function
+must take one argument (the automatically generated key), and must
+return with a string (the key to use)."
+ :group 'bibtex-autokey
+ :type '(choice (const nil) function))
+
+(defcustom bibtex-entry-offset 0
+ "*Offset for BibTeX entries.
+Added to the value of all other variables which determine colums."
+ :group 'bibtex
+ :type 'integer)
+
+(defcustom bibtex-field-indentation 2
+ "*Starting column for the name part in BibTeX fields."
+ :group 'bibtex
+ :type 'integer)
+
+(defcustom bibtex-text-indentation
+ (+
+ bibtex-field-indentation
+ (length "organization = "))
+ "*Starting column for the text part in BibTeX fields.
+Should be equal to the space needed for the longest name part."
+ :group 'bibtex
+ :type 'integer)
+
+(defcustom bibtex-contline-indentation
+ (+ bibtex-text-indentation 1)
+ "*Starting column for continuation lines of BibTeX fields."
+ :group 'bibtex
+ :type 'integer)
+
+(defcustom bibtex-align-at-equal-sign nil
+ "*If non-nil, align fields at equal sign instead of field text.
+If non-nil, the column for the equal sign is
+the value of `bibtex-text-indentation', minus 2."
+ :group 'bibtex
+ :type 'boolean)
+
+(defcustom bibtex-comma-after-last-field nil
+ "*If non-nil, a comma is put at end of last field in the entry template."
+ :group 'bibtex
+ :type 'boolean)
+
+;; bibtex-font-lock-keywords is a user option as well, but since the
+;; patterns used to define this variable are defined in a later
+;; section of this file, it is defined later.
+\f
+;; Special support taking care of variants
+(if (boundp 'mark-active)
+ (defun bibtex-mark-active ()
+ ;; In Emacs mark-active indicates if mark is active.
+ mark-active)
+ (defun bibtex-mark-active ()
+ ;; In XEmacs (mark) returns nil when not active.
+ (if zmacs-regions (mark) (mark t))))
+
+(if (fboundp 'run-with-idle-timer)
+ ;; timer.el is distributed with Emacs
+ (fset 'bibtex-run-with-idle-timer 'run-with-idle-timer)
+ ;; timer.el is not distributed with XEmacs
+ ;; Notice that this does not (yet) pass the arguments, but they
+ ;; are not used (yet) in bibtex.el. Fix if needed.
+ (defun bibtex-run-with-idle-timer (secs repeat function &rest args)
+ (start-itimer "bibtex" function secs (if repeat secs nil) t)))
+
+\f
+;; Support for hideshow minor mode
+(defun bibtex-hs-forward-sexp (arg)
+ "Replacement for `forward-sexp' to be used by `hs-minor-mode'."
+ (if (< arg 0)
+ (backward-sexp 1)
+ (if (looking-at "@\\S(*\\s(")
+ (progn
+ (goto-char (match-end 0))
+ (forward-char -1)
+ (forward-sexp 1))
+ (forward-sexp 1))))
+
+(add-to-list
+ 'hs-special-modes-alist
+ '(bibtex-mode "@\\S(*\\s(" "\\s)" nil bibtex-hs-forward-sexp nil))
+
+\f
+;; Syntax Table, Keybindings and BibTeX Entry List
+(defvar bibtex-mode-syntax-table
+ (let ((st (make-syntax-table)))
+ (modify-syntax-entry ?\" "\"" st)
+ (modify-syntax-entry ?$ "$$ " st)
+ (modify-syntax-entry ?% "< " st)
+ (modify-syntax-entry ?' "w " st)
+ (modify-syntax-entry ?@ "w " st)
+ (modify-syntax-entry ?\\ "\\" st)
+ (modify-syntax-entry ?\f "> " st)
+ (modify-syntax-entry ?\n "> " st)
+ (modify-syntax-entry ?~ " " st)
+ st))
+
+(defvar bibtex-mode-map
+ (let ((km (make-sparse-keymap)))
+ ;; The Key `C-c&' is reserved for reftex.el
+ (define-key km "\t" 'bibtex-find-text)
+ (define-key km "\n" 'bibtex-next-field)
+ (define-key km "\M-\t" 'bibtex-complete-string)
+ (define-key km [(meta tab)] 'bibtex-complete-key)
+ (define-key km "\C-c\"" 'bibtex-remove-delimiters)
+ (define-key km "\C-c{" 'bibtex-remove-delimiters)
+ (define-key km "\C-c}" 'bibtex-remove-delimiters)
+ (define-key km "\C-c\C-c" 'bibtex-clean-entry)
+ (define-key km "\C-c\C-q" 'bibtex-fill-entry)
+ (define-key km "\C-c?" 'bibtex-print-help-message)
+ (define-key km "\C-c\C-p" 'bibtex-pop-previous)
+ (define-key km "\C-c\C-n" 'bibtex-pop-next)
+ (define-key km "\C-c\C-k" 'bibtex-kill-field)
+ (define-key km "\C-c\M-k" 'bibtex-copy-field-as-kill)
+ (define-key km "\C-c\C-w" 'bibtex-kill-entry)
+ (define-key km "\C-c\M-w" 'bibtex-copy-entry-as-kill)
+ (define-key km "\C-c\C-y" 'bibtex-yank)
+ (define-key km "\C-c\M-y" 'bibtex-yank-pop)
+ (define-key km "\C-c\C-d" 'bibtex-empty-field)
+ (define-key km "\C-c\C-f" 'bibtex-make-field)
+ (define-key km "\C-c$" 'bibtex-ispell-abstract)
+ (define-key km "\M-\C-a" 'bibtex-beginning-of-entry)
+ (define-key km "\M-\C-e" 'bibtex-end-of-entry)
+ (define-key km "\C-\M-l" 'bibtex-reposition-window)
+ (define-key km "\C-\M-h" 'bibtex-mark-entry)
+ (define-key km "\C-c\C-b" 'bibtex-entry)
+ (define-key km "\C-c\C-rn" 'bibtex-narrow-to-entry)
+ (define-key km "\C-c\C-rw" 'widen)
+ (define-key km "\C-c\C-o" 'bibtex-remove-OPT-or-ALT)
+ (define-key km "\C-c\C-e\C-i" 'bibtex-InProceedings)
+ (define-key km "\C-c\C-ei" 'bibtex-InCollection)
+ (define-key km "\C-c\C-eI" 'bibtex-InBook)
+ (define-key km "\C-c\C-e\C-a" 'bibtex-Article)
+ (define-key km "\C-c\C-e\C-b" 'bibtex-InBook)
+ (define-key km "\C-c\C-eb" 'bibtex-Book)
+ (define-key km "\C-c\C-eB" 'bibtex-Booklet)
+ (define-key km "\C-c\C-e\C-c" 'bibtex-InCollection)
+ (define-key km "\C-c\C-e\C-m" 'bibtex-Manual)
+ (define-key km "\C-c\C-em" 'bibtex-MastersThesis)
+ (define-key km "\C-c\C-eM" 'bibtex-Misc)
+ (define-key km "\C-c\C-e\C-p" 'bibtex-InProceedings)
+ (define-key km "\C-c\C-ep" 'bibtex-Proceedings)
+ (define-key km "\C-c\C-eP" 'bibtex-PhdThesis)
+ (define-key km "\C-c\C-e\M-p" 'bibtex-Preamble)
+ (define-key km "\C-c\C-e\C-s" 'bibtex-String)
+ (define-key km "\C-c\C-e\C-t" 'bibtex-TechReport)
+ (define-key km "\C-c\C-e\C-u" 'bibtex-Unpublished)
+ km))
+
+(easy-menu-define
+ bibtex-edit-menu bibtex-mode-map "BibTeX-Edit Menu in BibTeX mode"
+ '("BibTeX-Edit"
+ ("Moving inside an Entry"
+ ["End of Field" bibtex-find-text t]
+ ["Next Field" bibtex-next-field t]
+ ["Beginning of Entry" bibtex-beginning-of-entry t]
+ ["End of Entry" bibtex-end-of-entry t])
+ ("Operating on Current Entry"
+ ["Fill Entry" bibtex-fill-entry t]
+ ["Clean Entry" bibtex-clean-entry t]
+ "--"
+ ["Kill Entry" bibtex-kill-entry t]
+ ["Copy Entry to Kill Ring" bibtex-copy-entry-as-kill t]
+ ["Paste Most Recently Killed Entry" bibtex-yank t]
+ ["Paste Previously Killed Entry" bibtex-yank-pop t]
+ "--"
+ ["Ispell Entry" bibtex-ispell-entry t]
+ ["Ispell Entry Abstract" bibtex-ispell-abstract t]
+ ["Narrow to Entry" bibtex-narrow-to-entry t]
+ "--"
+ ["View Cite Locations (RefTeX)" reftex-view-crossref-from-bibtex
+ (fboundp 'reftex-view-crossref-from-bibtex)])
+ ("Operating on Current Field"
+ ["Remove Delimiters" bibtex-remove-delimiters t]
+ ["Remove OPT or ALT Prefix" bibtex-remove-OPT-or-ALT t]
+ ["Clear Field" bibtex-empty-field t]
+ "--"
+ ["Kill Field" bibtex-kill-field t]
+ ["Copy Field to Kill Ring" bibtex-copy-field-as-kill t]
+ ["Paste Most Recently Killed Field" bibtex-yank t]
+ ["Paste Previously Killed Field" bibtex-yank-pop t]
+ "--"
+ ["Make New Field" bibtex-make-field t]
+ "--"
+ ["Snatch from Similar Following Field" bibtex-pop-next t]
+ ["Snatch from Similar Preceding Field" bibtex-pop-previous t]
+ "--"
+ ["String Complete" bibtex-complete-string t]
+ ["Key Complete" bibtex-complete-key t]
+ "--"
+ ["Help about Current Field" bibtex-print-help-message t])
+ ("Operating on Buffer or Region"
+ ["Validate Entries" bibtex-validate t]
+ ["Sort Entries" bibtex-sort-buffer t]
+ ["Reformat Entries" bibtex-reformat t]
+ ["Count Entries" bibtex-count-entries t])
+ ("Miscellaneous"
+ ["Convert Alien Buffer" bibtex-convert-alien t]
+ ["Submit Bug Report" bibtex-submit-bug-report t])))
+
+(easy-menu-define
+ bibtex-entry-menu bibtex-mode-map "Entry-Types Menu in BibTeX mode"
+ (list "Entry-Types"
+ ["Article in Journal" bibtex-Article t]
+ ["Article in Conference Proceedings" bibtex-InProceedings t]
+ ["Article in a Collection" bibtex-InCollection t]
+ ["Chapter or Pages in a Book" bibtex-InBook t]
+ ["Conference Proceedings" bibtex-Proceedings t]
+ ["Book" bibtex-Book t]
+ ["Booklet (Bound, but no Publisher/Institution)" bibtex-Booklet t]
+ ["PhD. Thesis" bibtex-PhdThesis t]
+ ["Master's Thesis" bibtex-MastersThesis t]
+ ["Technical Report" bibtex-TechReport t]
+ ["Technical Manual" bibtex-Manual t]
+ ["Unpublished" bibtex-Unpublished t]
+ ["Miscellaneous" bibtex-Misc t]
+ ["String" bibtex-String t]
+ ["Preamble" bibtex-Preamble t]))
+
+\f
+;; Internal Variables
+
+(defvar bibtex-pop-previous-search-point nil)
+;; Next point where bibtex-pop-previous starts looking for a similar
+;; entry.
+
+(defvar bibtex-pop-next-search-point nil)
+;; Next point where bibtex-pop-next starts looking for a similar entry.
+
+(defvar bibtex-field-kill-ring nil)
+;; Ring of least recently killed fields. At most
+;; bibtex-field-kill-ring-max items are kept here.
+
+(defvar bibtex-field-kill-ring-yank-pointer nil)
+;; The tail of bibtex-field-kill-ring whose car is the last item yanked.
+
+(defvar bibtex-entry-kill-ring nil)
+;; Ring of least recently killed entries. At most
+;; bibtex-entry-kill-ring-max items are kept here.
+
+(defvar bibtex-entry-kill-ring-yank-pointer nil)
+;; The tail of bibtex-entry-kill-ring whose car is the last item yanked.
+
+(defvar bibtex-last-kill-command nil)
+;; Holds the type of the last kill command (either 'field or 'entry)
+
+(defvar bibtex-strings nil)
+;; Candidates for bibtex-complete-string. Initialized from
+;; bibtex-predefined-strings and bibtex-string-files.
+(make-variable-buffer-local 'bibtex-strings)
+
+(defvar bibtex-reference-keys nil)
+;; Candidates for TAB completion when entering a reference key using
+;; the minibuffer. Also used for bibtex-complete-key. Initialized in
+;; bibtex-mode and updated for each new entry.
+(make-variable-buffer-local 'bibtex-reference-keys)
+
+(defvar bibtex-buffer-last-parsed-tick nil)
+;; Remembers the value returned by buffer-modified-tick when buffer
+;; was parsed for keys the last time.
+(make-variable-buffer-local 'bibtex-buffer-last-parsed-tick)
+
+(defvar bibtex-parse-idle-timer nil)
+;; Stores if timer is already installed
+
+(defvar bibtex-progress-lastperc nil)
+;; Holds the last reported percentage for the progress message
+
+(defvar bibtex-progress-lastmes nil)
+;; Holds the last reported progress message
+
+(defvar bibtex-progress-interval nil)
+;; Holds the chosen interval
+
+(defvar bibtex-key-history nil)
+;; Used to store the history list for reading keys
+
+(defvar bibtex-entry-type-history nil)
+;; Used to store the history list for reading entry types
+
+(defvar bibtex-field-history nil)
+;; Used to store the history list for reading field names
+
+(defvar bibtex-reformat-previous-options nil)
+;; Used to store the last reformat options given
+
+(defvar bibtex-reformat-previous-reference-keys nil)
+;; Used to store the last reformat reference keys option given
+
+\f
+;; Functions to Parse the BibTeX Entries
+
+(defconst bibtex-field-name "[^\"#%'(),={} \t\n0-9][^\"#%'(),={} \t\n]*")
+;; Regexp defining the name part of a BibTeX field.
+
+(defconst bibtex-entry-type (concat "@" bibtex-field-name))
+;; Regexp defining the type part of a BibTeX entry.
+
+(defconst bibtex-reference-key "[][a-zA-Z0-9.:;?!`'/*@+=|()<>&_^$-]+")
+;; Regexp defining the reference key part of a BibTeX entry
+
+(defun bibtex-parse-nested-braces (nesting-level)
+ "*Starting on an opening brace, find the corresponding closing brace.
+When the function is called, NESTING-LEVEL has to be set to `0'."
+ (cond ((looking-at "{")
+ (search-forward-regexp "{[^{}]*")
+ (bibtex-parse-nested-braces (+ nesting-level 1)))
+ ((looking-at "}")
+ (forward-char 1)
+ (if (= nesting-level 1)
+ (point)
+ (search-forward-regexp "[^{}]*")
+ (bibtex-parse-nested-braces (- nesting-level 1))))
+ (t nil)))
+
+(defun bibtex-parse-field-string-braced ()
+ "*Parse a field string enclosed by braces.
+The field string has to be syntactically correct, which means that the number
+of opening and closing braces has to match. If this is the case, a pair
+containing the start and end position of the field string is returned, nil
+otherwise."
+ (save-match-data
+ (let ((starting-point (point))
+ (end-point nil))
+ (if (looking-at "{")
+ (setq end-point (bibtex-parse-nested-braces 0)))
+ (goto-char starting-point)
+ (if end-point
+ (cons starting-point end-point)
+ nil))))
+
+(defun bibtex-parse-quoted-string ()
+ "*Starting on an opening quote, find the corresponding closing quote."
+ (let ((rx (concat "\""
+ "\\("
+ "[^\"\\]" ;; anything but quote or backslash
+ "\\|"
+ "\\("
+ "\\\\\\(.\\|\n\\)" ;; any backslash quoted character
+ "\\)"
+ "\\)*"
+ "\"")))
+ (if (looking-at rx)
+ (search-forward-regexp rx nil t)
+ nil)))
+
+(defun bibtex-parse-field-string-quoted ()
+ "*Parse a field string enclosed by quotes.
+If a syntactically correct string is found, a pair containing the start and
+end position of the field string is returned, nil otherwise."
+ (save-match-data
+ (let ((starting-point (point))
+ (end-point nil))
+ (if (looking-at "\"")
+ (setq end-point (bibtex-parse-quoted-string)))
+ (goto-char starting-point)
+ (if end-point
+ (cons starting-point end-point)
+ nil))))
+
+(defun bibtex-parse-field-string ()
+ "*Parse a field string enclosed by braces or quotes.
+If a syntactically correct string is found, a pair containing the start and
+end position of the field string is returned, nil otherwise."
+ (save-match-data
+ (let ((starting-point (point))
+ (boundaries (or (bibtex-parse-field-string-braced)
+ (bibtex-parse-field-string-quoted))))
+ (goto-char starting-point)
+ boundaries)))
+
+(defun bibtex-search-forward-field-string (bound)
+ "*Search forward to find a field string enclosed by braces or quotes.
+If a syntactically correct string is found, a pair containing the start and
+end position of the field string is returned, nil otherwise. The search is
+delimited by BOUND."
+ (save-match-data
+ (let ((starting-point (point))
+ (boundaries nil))
+ (while (and (not boundaries) (< (point) bound))
+ (if (search-forward-regexp "[{\"]" bound 'move)
+ (progn
+ (goto-char (match-beginning 0))
+ (let ((temp-boundaries (or (bibtex-parse-field-string-braced)
+ (bibtex-parse-field-string-quoted))))
+ (if (and temp-boundaries (<= (cdr temp-boundaries) bound))
+ (setq boundaries temp-boundaries)
+ (forward-char 1))))))
+ (goto-char starting-point)
+ boundaries)))
+
+(defun bibtex-parse-association (parse-lhs parse-rhs)
+ "*Parse a string of the format <left hand side = right-hand-side>.
+The functions PARSE-LHS and PARSE-RHS are used to parse the corresponding
+substrings. These functions are expected to return nil if parsing is not
+successfull. If both functions return non-nil, a pair containing the returned
+values of the functions PARSE-LHS and PARSE-RHSis returned."
+ (save-match-data
+ (let ((starting-point (point))
+ (left (funcall parse-lhs))
+ (right nil))
+ (if (and left (looking-at "[ \t\n]*=[ \t\n]*"))
+ (progn
+ (goto-char (match-end 0))
+ (setq right (funcall parse-rhs))))
+ (goto-char starting-point)
+ (if (and left right)
+ (cons left right)
+ nil))))
+
+(defvar bibtex-field-name-for-parsing nil)
+;; Temporary variable storing the name string to be parsed by the callback
+;; function bibtex-parse-field-name.
+(make-variable-buffer-local 'bibtex-field-name-for-parsing)
+
+(defun bibtex-parse-field-name ()
+ "*Parse the field name stored in bibtex-field-name-for-parsing.
+If the field name is found, return a triple consisting of the position of the
+very first character of the match, the actual starting position of the name
+part and end position of the match."
+ (if (looking-at ",[ \t\n]*")
+ (let ((start (point)))
+ (goto-char (match-end 0))
+ (if (looking-at bibtex-field-name-for-parsing)
+ (let ((boundaries (list start (match-beginning 0) (match-end 0))))
+ (goto-char (match-end 0))
+ boundaries)))))
+
+(defconst bibtex-field-const "[][a-zA-Z0-9.:;?!`'/*@+=|<>&_^$-]+")
+;; Regexp defining a bibtex field constant
+
+(defun bibtex-parse-field-text ()
+ "*Parse the text part of a BibTeX field.
+The text part is either a string, or an empty string, or a constant followed
+by one or more <# (string|constant)> pairs. If a syntactically correct text
+is found, a pair containing the start and end position of the text is
+returned, nil otherwise."
+ (let ((starting-point (point))
+ (end-point nil)
+ (failure nil))
+ (while (and (not end-point) (not failure))
+ (if (looking-at bibtex-field-const)
+ (goto-char (match-end 0))
+ (let ((boundaries (bibtex-parse-field-string)))
+ (if boundaries
+ (goto-char (cdr boundaries))
+ (setq failure t))))
+ (if (not (looking-at "[ \t\n]*#[ \t\n]*"))
+ (setq end-point (point))
+ (goto-char (match-end 0))))
+ (if (and (not failure) end-point)
+ (cons starting-point end-point)
+ nil)))
+
+(defun bibtex-parse-field (name)
+ "*Parse a BibTeX field of regexp NAME.
+If a syntactically correct field is found, a pair containing the boundaries of
+the name and text parts of the field is returned."
+ (setq bibtex-field-name-for-parsing name)
+ (bibtex-parse-association 'bibtex-parse-field-name
+ 'bibtex-parse-field-text))
+
+(defun bibtex-search-forward-field (name bound)
+ "*Search forward to find a field of name NAME.
+If a syntactically correct field is found, a pair containing the boundaries of
+the name and text parts of the field is returned. The search is limited by
+BOUND."
+ (save-match-data
+ (setq bibtex-field-name-for-parsing name)
+ (let ((starting-point (point))
+ (boundaries nil))
+ (while (and (not boundaries)
+ (< (point) bound)
+ (search-forward "," bound t))
+ (goto-char (match-beginning 0))
+ (let ((temp-boundaries
+ (bibtex-parse-association 'bibtex-parse-field-name
+ 'bibtex-parse-field-text)))
+ (if (and temp-boundaries (<= (cdr (cdr temp-boundaries)) bound))
+ (setq boundaries temp-boundaries)
+ (forward-char 1))))
+ (goto-char starting-point)
+ boundaries)))
+
+(defun bibtex-search-backward-field (name bound)
+ "*Search backward to find a field of name NAME.
+If a syntactically correct field is found, a pair containing the boundaries of
+the name and text parts of the field is returned. The search is limited by
+BOUND."
+ (save-match-data
+ (setq bibtex-field-name-for-parsing name)
+ (let ((starting-point (point))
+ (boundaries nil))
+ (while (and (not boundaries)
+ (>= (point) bound)
+ (search-backward "," bound t))
+ (let ((temp-boundaries
+ (bibtex-parse-association 'bibtex-parse-field-name
+ 'bibtex-parse-field-text)))
+ (if temp-boundaries
+ (setq boundaries temp-boundaries))))
+ (goto-char starting-point)
+ boundaries)))
+
+(defun bibtex-start-of-field (bounds)
+ (car (car bounds)))
+(defun bibtex-end-of-field (bounds)
+ (cdr (cdr bounds)))
+(defun bibtex-start-of-name-in-field (bounds)
+ (car (cdr (car bounds))))
+(defun bibtex-end-of-name-in-field (bounds)
+ (car (cdr (cdr (car bounds)))))
+(defun bibtex-start-of-text-in-field (bounds)
+ (car (cdr bounds)))
+(defun bibtex-end-of-text-in-field (bounds)
+ (cdr (cdr bounds)))
+
+(defun bibtex-parse-string-prefix ()
+ "*Parse the prefix part of a bibtex string, including the reference key.
+If the string prefix is found, return a triple consisting of the position of
+the very first character of the match, the actual starting position of the
+reference key and the end position of the match."
+ (let* ((case-fold-search t))
+ (if (looking-at "^[ \t]*@string[ \t\n]*[({][ \t\n]*")
+ (let ((start (point)))
+ (goto-char (match-end 0))
+ (if (looking-at bibtex-reference-key)
+ (let ((boundaries (list start (match-beginning 0) (match-end 0))))
+ (goto-char (match-end 0))
+ boundaries))))))
+
+(defun bibtex-parse-string-postfix ()
+ "*Parse the postfix part of a bibtex string, including the text.
+If the string postfix is found, return a triple consisting of the position of
+the actual starting and ending position of the text and the very last
+character of the string entry."
+ (let* ((case-fold-search t)
+ (text-boundaries (bibtex-parse-field-text)))
+ (if text-boundaries
+ (progn
+ (goto-char (cdr text-boundaries))
+ (if (looking-at "[ \t\n]*[})]")
+ (let ((boundaries (list (car text-boundaries)
+ (cdr text-boundaries)
+ (match-end 0))))
+ (goto-char (match-end 0))
+ boundaries))))))
+
+(defun bibtex-parse-string ()
+ "*Parse a BibTeX string entry.
+If a syntactically correct entry is found, a pair containing the boundaries of
+the reference key and text parts of the entry is returned."
+ (bibtex-parse-association 'bibtex-parse-string-prefix
+ 'bibtex-parse-string-postfix))
+
+(defun bibtex-search-forward-string ()
+ "*Search forward to find a bibtex string entry.
+If a syntactically correct entry is found, a pair containing the boundaries of
+the reference key and text parts of the string is returned."
+ (save-match-data
+ (let* ((case-fold-search t)
+ (starting-point (point))
+ (boundaries nil))
+ (while (and (not boundaries)
+ (search-forward-regexp
+ "^[ \t]*@string[ \t\n]*[({][ \t\n]*" nil t))
+ (goto-char (match-beginning 0))
+ (let ((temp-boundaries (bibtex-parse-string)))
+ (if temp-boundaries
+ (setq boundaries temp-boundaries)
+ (forward-char 1))))
+ (goto-char starting-point)
+ boundaries)))
+
+(defun bibtex-search-backward-string ()
+ "*Search backward to find a bibtex string entry.
+If a syntactically correct entry is found, a pair containing the boundaries of
+the reference key and text parts of the field is returned."
+ (save-match-data
+ (let* ((case-fold-search t)
+ (starting-point (point))
+ (boundaries nil))
+ (while (and (not boundaries)
+ (search-backward-regexp
+ "^[ \t]*@string[ \t\n]*[({][ \t\n]*" nil t))
+ (goto-char (match-beginning 0))
+ (let ((temp-boundaries (bibtex-parse-string)))
+ (if temp-boundaries
+ (setq boundaries temp-boundaries))))
+ (goto-char starting-point)
+ boundaries)))
+
+(defun bibtex-end-of-string (bounds)
+ (car (cdr (cdr (cdr bounds)))))
+(defun bibtex-start-of-reference-key-in-string (bounds)
+ (car (cdr (car bounds))))
+(defun bibtex-end-of-reference-key-in-string (bounds)
+ (car (cdr (cdr (car bounds)))))
+(defun bibtex-start-of-text-in-string (bounds)
+ (car (cdr bounds)))
+(defun bibtex-end-of-text-in-string (bounds)
+ (car (cdr (cdr bounds))))
+
+(defconst bibtex-entry-head
+ (concat "^[ \t]*\\("
+ bibtex-entry-type
+ "\\)[ \t]*[({][ \t\n]*\\("
+ bibtex-reference-key
+ "\\)"))
+;; Regexp defining format of the header line of a BibTeX entry.
+
+(defconst bibtex-entry-maybe-empty-head
+ (concat bibtex-entry-head "?"))
+;; Regexp defining format of the header line of a maybe empty
+;; BibTeX entry (possibly without reference key).
+
+(defconst bibtex-type-in-head 1)
+;; The regexp subexpression number of the type part in
+;; bibtex-entry-head.
+
+(defconst bibtex-key-in-head 2)
+;; The regexp subexpression number of the key part in
+;; bibtex-entry-head.
+
+(defconst bibtex-entry-postfix "[ \t\n]*,?[ \t\n]*[})]")
+;; Regexp defining the postfix of a bibtex entry
+
+(defconst bibtex-key-in-entry bibtex-key-in-head)
+;; The regexp subexpression number of the key part in a bibtex entry.
+
+(defvar bibtex-font-lock-keywords
+ (list
+ ;; entry type and reference key
+ (list bibtex-entry-maybe-empty-head
+ (list bibtex-type-in-head 'font-lock-function-name-face)
+ (list bibtex-key-in-head 'font-lock-constant-face nil t))
+ ;; comments
+ (list
+ (concat "^\\([ \t]*" bibtex-comment-start ".*\\)$")
+ 1 'font-lock-comment-face)
+ ;; optional field names (treated as comments)
+ (list
+ (concat "^[ \t]*\\(OPT" bibtex-field-name "\\)[ \t]*=")
+ 1 'font-lock-comment-face)
+ ;; field names
+ (list (concat "^[ \t]*\\(" bibtex-field-name "\\)[ \t]*=")
+ 1 'font-lock-variable-name-face)
+ "*Default expressions to highlight in BibTeX mode."))
+;; now all needed patterns are defined
+
+
+\f
+;; Helper Functions
+
+(defun bibtex-delete-whitespace ()
+ ;; Delete all whitespace starting at point
+ (if (looking-at "[ \t\n]+")
+ (delete-region (point) (match-end 0))))
+
+(defun bibtex-current-line ()
+ ;; this computes line number of point regardless whether the buffer
+ ;; is narrowed
+ (+ (count-lines 1 (point))
+ (if (equal (current-column) 0) 1 0)))
+
+(defun bibtex-member-of-regexp (string list)
+ ;; Return non-nil if STRING is exactly matched by an element of
+ ;; LIST. The value is actually the tail of LIST whose
+ ;; car matches STRING.
+ (let* (case-fold-search)
+ (while
+ (and list (not (string-match (concat "^" (car list) "$") string)))
+ (setq list (cdr list)))
+ list))
+
+(defun bibtex-assoc-of-regexp (string alist)
+ ;; Return non-nil if STRING is exactly matched by the car of an
+ ;; element of LIST (case ignored). The value is actually the element
+ ;; of LIST whose car matches STRING.
+ (let* ((case-fold-search t))
+ (while
+ (and alist
+ (not (string-match (concat "^" (car (car alist)) "$") string)))
+ (setq alist (cdr alist)))
+ (car alist)))
+
+(defun bibtex-skip-to-valid-entry (&optional backward)
+ ;; If not at beginning of valid BibTeX entry, move to beginning of
+ ;; the next valid one. With argument backward non-nil, move backward
+ ;; to beginning of previous valid one. A valid entry is a
+ ;; syntactical correct one with type contained in
+ ;; bibtex-entry-field-alist or, if bibtex-sort-ignore-string-entries
+ ;; is nil, a syntactical correct string entry.
+ (let* ((case-fold-search t)
+ (valid-bibtex-entry
+ (concat
+ "@[ \t]*\\("
+ (mapconcat
+ (lambda (type)
+ (concat "\\(" (car type) "\\)"))
+ bibtex-entry-field-alist
+ "\\|")
+ "\\)"))
+ found)
+ (while (and (not found)
+ (not (if backward
+ (bobp)
+ (eobp))))
+ (let ((pnt (point)))
+ (cond
+ ((looking-at valid-bibtex-entry)
+ (if (and
+ (bibtex-search-entry nil nil t)
+ (equal (match-beginning 0) pnt))
+ (setq found t)))
+ ((and (not bibtex-sort-ignore-string-entries)
+ (bibtex-parse-string))
+ (setq found t)))
+ (if found
+ (goto-char pnt)
+ (if backward
+ (progn
+ (goto-char (1- pnt))
+ (if (re-search-backward "^[ \t]*\\(@\\)" nil 'move)
+ (goto-char (match-beginning 1))))
+ (goto-char (1+ pnt))
+ (if (re-search-forward "^[ \t]*@" nil 'move)
+ (forward-char -1))))))))
+
+(defun bibtex-map-entries (fun)
+ ;; Call FUN for each BibTeX entry starting with the current. Do this
+ ;; to the end of the file. FUN is called with one argument, the key
+ ;; of the entry, and with point inside the entry. If
+ ;; bibtex-sort-ignore-string-entries is non-nil, FUN will not be
+ ;; called for @String entries.
+ (let* ((case-fold-search t))
+ (bibtex-beginning-of-entry)
+ (while (re-search-forward bibtex-entry-maybe-empty-head nil t)
+ (let ((pnt (point))
+ (entry-type
+ (downcase (buffer-substring-no-properties
+ (1+ (match-beginning bibtex-type-in-head))
+ (match-end bibtex-type-in-head))))
+ (reference-key
+ (if (match-beginning bibtex-key-in-head)
+ (buffer-substring-no-properties
+ (match-beginning bibtex-key-in-head)
+ (match-end bibtex-key-in-head))
+ "")))
+ (if (or
+ (and
+ (not bibtex-sort-ignore-string-entries)
+ (string-equal "string" (downcase entry-type)))
+ (assoc-ignore-case entry-type bibtex-entry-field-alist))
+ (funcall fun reference-key))
+ (goto-char pnt)
+ (bibtex-end-of-entry)))))
+
+(defun bibtex-progress-message (&optional flag interval)
+ ;; echos a message about progress of current buffer
+ ;; if flag is a string, the message is initialized (in this case a
+ ;; value for INTERVAL may be given as well (if not this is set to 5))
+ ;; if flag is done, the message is deinitialized
+ ;; if flag is absent, a message is echoed if point was incremented
+ ;; at least INTERVAL percent since last message was echoed
+ (let* ((size (- (point-max) (point-min)))
+ (perc (if (= size 0)
+ 100
+ (/ (* 100 (- (point) (point-min))) size))))
+ (if (or (and (not flag)
+ (>= perc
+ (+ bibtex-progress-interval bibtex-progress-lastperc)))
+ (stringp flag))
+ (progn
+ (if (stringp flag)
+ (progn
+ (setq bibtex-progress-lastmes flag)
+ (if interval
+ (setq bibtex-progress-interval interval)
+ (setq bibtex-progress-interval 5))))
+ (setq bibtex-progress-lastperc perc)
+ (message (concat bibtex-progress-lastmes " (%d%%)") perc))
+ (if (equal flag 'done)
+ (progn
+ (message (concat bibtex-progress-lastmes " (done)"))
+ (setq bibtex-progress-lastmes nil))))))
+
+
+(defun bibtex-field-left-delimiter ()
+ ;; returns a string dependent on bibtex-field-delimiters
+ (if (equal bibtex-field-delimiters 'braces)
+ "{"
+ "\""))
+
+(defun bibtex-field-right-delimiter ()
+ ;; returns a string dependent on bibtex-field-delimiters
+ (if (equal bibtex-field-delimiters 'braces)
+ "}"
+ "\""))
+
+(defun bibtex-entry-left-delimiter ()
+ ;; returns a string dependent on bibtex-field-delimiters
+ (if (equal bibtex-entry-delimiters 'braces)
+ "{"
+ "("))
+
+(defun bibtex-entry-right-delimiter ()
+ ;; returns a string dependent on bibtex-field-delimiters
+ (if (equal bibtex-entry-delimiters 'braces)
+ "}"
+ ")"))
+
+(defun bibtex-search-entry
+ (empty-head &optional bound noerror backward)
+ ;; A helper function necessary since the failure stack size limit for
+ ;; regexps was reduced in emacs 19.32.
+ ;; It searches for a BibTeX entry (maybe without a reference key if
+ ;; EMPTY-HEAD is t).
+ ;; BOUND and NOERROR are exactly as in re-search-forward. If
+ ;; BACKWARD is non-nil, search is done in reverse direction. After
+ ;; call to this function MATCH-BEGINNING and MATCH-END functions are
+ ;; defined, but only for the head part of the entry (especially
+ ;; (match-end 0) just gives the end of the head part).
+ (let ((pnt (point))
+ (prefix (if empty-head
+ bibtex-entry-maybe-empty-head
+ bibtex-entry-head)))
+ (if backward
+ (let (found)
+ (while (and (not found)
+ (re-search-backward prefix bound noerror))
+ (setq found (bibtex-search-entry empty-head pnt t)))
+ (if found
+ (goto-char (match-beginning 0))
+ (if (equal noerror nil)
+ ;; yell
+ (error "Search of BibTeX entry failed"))
+ (if (equal noerror t)
+ ;; don't move
+ (goto-char pnt))
+ nil))
+ (let ((limit (if bound bound (point-max)))
+ md
+ found)
+ (while (and (not found)
+ (re-search-forward prefix bound noerror))
+ (setq md (match-data))
+ ;; save match-data of prefix regexp
+ (let ((entry-closer
+ (if (save-excursion
+ (goto-char (match-end bibtex-type-in-head))
+ (looking-at "[ \t]*("))
+ ;; entry opened with parenthesis
+ ")"
+ "}")))
+ (let ((infix-start (point))
+ (finished nil))
+ (while (not finished)
+ (if (and (looking-at "[ \t\n]*")
+ (<= (match-end 0) limit))
+ (goto-char (match-end 0)))
+ (let ((bounds (bibtex-parse-field bibtex-field-name)))
+ (if (and bounds (<= (bibtex-end-of-field bounds) limit))
+ (progn
+ (goto-char (bibtex-end-of-field bounds))
+ (setq infix-start (point)))
+ (goto-char infix-start)
+ (setq finished t)))))
+ ;; This matches the infix* part. The AND construction assures
+ ;; that BOUND is respected.
+ (if (and (looking-at bibtex-entry-postfix)
+ (string-equal
+ (buffer-substring-no-properties
+ (1- (match-end 0)) (match-end 0))
+ entry-closer)
+ (<= (match-end 0) limit))
+ (progn
+ (re-search-forward bibtex-entry-postfix)
+ (setq found t)))))
+ (if found
+ (progn
+ (set-match-data md)
+ ;; to set match-beginning/end again
+ (point))
+ (if (equal noerror nil)
+ ;; yell
+ (error "Search of BibTeX entry failed"))
+ (if (equal noerror t)
+ ;; don't move
+ (goto-char pnt))
+ nil)))))
+
+(defun bibtex-flash-head ()
+ ;; Flash at BibTeX entry head before point, if exists.
+ (let* ((case-fold-search t)
+ flash)
+ (cond ((re-search-backward bibtex-entry-head nil t)
+ (goto-char (match-beginning bibtex-type-in-head))
+ (setq flash (match-end bibtex-key-in-entry)))
+ (t
+ (end-of-line)
+ (skip-chars-backward " \t")
+ (setq flash (point))
+ (beginning-of-line)
+ (skip-chars-forward " \t")))
+ (if (pos-visible-in-window-p (point))
+ (sit-for 1)
+ (message "From: %s"
+ (buffer-substring (point) flash)))))
+
+(defun bibtex-make-optional-field (e-t)
+ "Makes an optional field named E-T in current BibTeX entry."
+ (if (consp e-t)
+ (bibtex-make-field (cons (concat "OPT" (car e-t)) (cdr e-t)))
+ (bibtex-make-field (concat "OPT" e-t))))
+
+(defun bibtex-move-outside-of-entry ()
+ ;; Make sure we are outside of a BibTeX entry.
+ (let ((orig-point (point)))
+ (bibtex-end-of-entry)
+ (if (< (point) orig-point)
+ ;; We moved backward, so we weren't inside an entry to begin with.
+ ;; Leave point at the beginning of a line, and preferably
+ ;; at the beginning of a paragraph.
+ (progn
+ (goto-char orig-point)
+ (beginning-of-line 1)
+ (if (not (= ?\n (char-before (1- (point)))))
+ (progn
+ (re-search-forward "^[ \t]*[@\n]" nil 'move)
+ (backward-char 1)))))
+ (skip-chars-forward " \t\n")))
+
+(defun bibtex-beginning-of-first-entry ()
+ ;; Go to the beginning of the first BibTeX entry in buffer. Return
+ ;; point.
+ (goto-char (point-min))
+ (if (re-search-forward "^[ \t]*@" nil 'move)
+ (beginning-of-line))
+ (point))
+
+(defun bibtex-beginning-of-last-entry ()
+ ;; Go to the beginning of the last BibTeX entry in buffer.
+ (goto-char (point-max))
+ (if (re-search-backward "^[ \t]*@" nil 'move)
+ (beginning-of-line))
+ (point))
+
+(defun bibtex-inside-field ()
+ ;; Try to avoid point being at end of a BibTeX field.
+ (end-of-line)
+ (skip-chars-backward " \t")
+ (cond ((= (preceding-char) ?,)
+ (forward-char -2)))
+ (cond ((or
+ (= (preceding-char) ?})
+ (= (preceding-char) ?\"))
+ (forward-char -1))))
+
+(defun bibtex-enclosing-field (&optional noerr)
+ ;; Search for BibTeX field enclosing point. Point moves to end of
+ ;; field. Use match-beginning and match-end to parse the field. If
+ ;; NOERR is non-nil, no error is signalled. In this case, t is
+ ;; returned on success, nil otherwise.
+ (let* ((case-fold-search t)
+ (old-point (point))
+ (boe (bibtex-beginning-of-entry)))
+ (goto-char old-point)
+ (let ((bounds (bibtex-search-backward-field bibtex-field-name boe)))
+ (if (and bounds
+ (<= (bibtex-start-of-field bounds) old-point)
+ (>= (bibtex-end-of-field bounds) old-point))
+ bounds
+ (if noerr
+ nil
+ (error "Can't find enclosing BibTeX field"))))))
+
+(defun bibtex-enclosing-entry-maybe-empty-head ()
+ ;; Search for BibTeX entry enclosing point. Point moves to
+ ;; end of entry. Beginning (but not end) of entry is given
+ ;; by (match-beginning 0).
+ (let* ((case-fold-search t)
+ (old-point (point)))
+ (if (not
+ (re-search-backward
+ bibtex-entry-maybe-empty-head nil t))
+ (progn
+ (error "Can't find enclosing BibTeX entry")
+ (goto-char old-point)))
+ (goto-char (match-beginning bibtex-type-in-head))
+ (if (not
+ (bibtex-search-entry t nil t))
+ (progn
+ (error "Can't find enclosing BibTeX entry")
+ (goto-char old-point)))))
+
+(defun bibtex-insert-current-kill (n)
+ (if (not bibtex-last-kill-command)
+ (error "BibTeX kill ring is empty")
+ (let* ((kr (if (equal bibtex-last-kill-command 'field)
+ 'bibtex-field-kill-ring
+ 'bibtex-entry-kill-ring))
+ (kryp (if (equal bibtex-last-kill-command 'field)
+ 'bibtex-field-kill-ring-yank-pointer
+ 'bibtex-entry-kill-ring-yank-pointer))
+ (ARGth-kill-element
+ (nthcdr
+ (mod (- n (length (eval kryp))) (length (eval kr)))
+ (eval kr)))
+ (current (car (set kryp ARGth-kill-element))))
+ (cond
+ ((equal bibtex-last-kill-command 'field)
+ (let (bibtex-help-message)
+ (bibtex-find-text nil t)
+ (if (looking-at "[}\"]")
+ (forward-char)))
+ (set-mark (point))
+ (message "Mark set")
+ (bibtex-make-field (list (elt current 1) nil (elt current 2)) t))
+ ((equal bibtex-last-kill-command 'entry)
+ (if (not (eobp))
+ (bibtex-beginning-of-entry))
+ (set-mark (point))
+ (message "Mark set")
+ (insert (elt current 1)))
+ (t
+ (error
+ "Unknown tag field: %s. Please submit a bug report"
+ bibtex-last-kill-command))))))
+
+(defun bibtex-format-field-delimiters (start stop)
+ "*Replaces delimiters for field strings between START and STOP.
+If the current delimiters equal the new delimiters, the buffer is not
+changed."
+ (goto-char start)
+ (let ((boundaries (bibtex-search-forward-field-string stop)))
+ (while boundaries
+ (goto-char (car boundaries))
+ (if (not (looking-at (bibtex-field-left-delimiter)))
+ (progn
+ (delete-char 1)
+ (insert (bibtex-field-left-delimiter))))
+ (goto-char (- (cdr boundaries) 1))
+ (if (not (looking-at (bibtex-field-right-delimiter)))
+ (progn
+ (delete-char 1)
+ (insert (bibtex-field-right-delimiter))))
+ (setq boundaries (bibtex-search-forward-field-string stop)))))
+
+(defun bibtex-format-entry ()
+ ;; Helper function for bibtex-clean-entry. Formats current entry
+ ;; according to variable bibtex-entry-format.
+ (let* ((case-fold-search t)
+ (beg (point))
+ (start (bibtex-beginning-of-entry))
+ crossref-there
+ alternatives-there
+ non-empty-alternative)
+ (let ((end (copy-marker (bibtex-end-of-entry))))
+ (if (equal start (marker-position end))
+ (error "Not on a known BibTeX entry")
+ (goto-char start)
+ (let ((bounds (bibtex-search-forward-field bibtex-field-name end)))
+ (while bounds
+ ;; determine if entry has crossref field and if at least
+ ;; one alternative is non-empty
+ (let ((begin-name (bibtex-start-of-name-in-field bounds))
+ (end-name (bibtex-end-of-name-in-field bounds))
+ (begin-text (bibtex-start-of-text-in-field bounds))
+ (end-text (bibtex-end-of-text-in-field bounds)))
+ (goto-char begin-name)
+ (if (looking-at "ALT")
+ (progn
+ (setq alternatives-there t)
+ (goto-char begin-text)
+ (if (not (looking-at "\\(\"\"\\)\\|\\({}\\)"))
+ (setq non-empty-alternative t))))
+ (if (string-match
+ "\\(OPT\\)?crossref"
+ (buffer-substring-no-properties begin-name end-name))
+ (progn
+ (setq
+ crossref-there
+ (buffer-substring-no-properties
+ (1+ begin-text) (1- end-text)))
+ (if (equal crossref-there "")
+ (setq crossref-there nil)))))
+ (goto-char (bibtex-end-of-field bounds))
+ (setq bounds (bibtex-search-forward-field bibtex-field-name end))))
+ (if (and alternatives-there
+ (not non-empty-alternative))
+ (progn
+ (goto-char beg)
+ (error "All alternatives are empty")))
+ (goto-char start)
+ (re-search-forward bibtex-entry-type end)
+ (let* ((begin-type (1+ (match-beginning 0)))
+ (end-type (match-end 0))
+ (entry-type
+ (downcase
+ (buffer-substring-no-properties begin-type end-type)))
+ (entry-list
+ (assoc-ignore-case entry-type bibtex-entry-field-alist))
+ (req (elt (elt entry-list 1) 0))
+ (creq (elt (elt entry-list 2) 0))
+ (format (if (equal bibtex-entry-format t)
+ '(realign opts-or-alts numerical-fields
+ last-comma page-dashes delimiters
+ unify-case inherit-booktitle)
+ bibtex-entry-format))
+ field-done)
+ (if (memq 'unify-case format)
+ (progn
+ (delete-region begin-type end-type)
+ (insert (car entry-list))))
+ (if (memq 'delimiters format)
+ (progn
+ (goto-char end-type)
+ (skip-chars-forward " \t\n")
+ (delete-char 1)
+ (insert (bibtex-entry-left-delimiter))))
+ (goto-char start)
+ (let ((bounds (bibtex-search-forward-field bibtex-field-name end)))
+ (while bounds
+ (let* ((begin-field (copy-marker (bibtex-start-of-field bounds)))
+ (end-field (copy-marker (bibtex-end-of-field bounds)))
+ (begin-name (copy-marker (bibtex-start-of-name-in-field bounds)))
+ (end-name (copy-marker (bibtex-end-of-name-in-field bounds)))
+ (begin-text (copy-marker (bibtex-start-of-text-in-field bounds)))
+ (end-text (copy-marker (bibtex-end-of-text-in-field bounds)))
+ (field-name
+ (buffer-substring-no-properties
+ (if (string-match
+ "^\\(OPT\\)\\|\\(ALT\\)$"
+ (buffer-substring-no-properties
+ begin-name (+ begin-name 3)))
+ (+ begin-name 3)
+ begin-name)
+ end-name)))
+ (cond
+ ((and
+ (memq 'opts-or-alts format)
+ (progn (goto-char begin-name)
+ (looking-at "OPT\\|ALT")))
+ (goto-char begin-text)
+ (if (looking-at "\\(\"\"\\)\\|\\({}\\)")
+ ;; empty: delete whole field if really optional
+ ;; (missing crossref handled) or complain
+ (if (and
+ (progn
+ (goto-char begin-name)
+ (looking-at "OPT"))
+ (not crossref-there)
+ (assoc-ignore-case field-name req))
+ ;; field is not really optional
+ (progn
+ (goto-char begin-name)
+ (bibtex-remove-OPT-or-ALT)
+ (error
+ "Mandatory field ``%s'' is empty" field-name))
+ ;; field is optional
+ (delete-region begin-field end-field))
+ ;; otherwise: not empty, delete "OPT"
+ (goto-char begin-name)
+ (bibtex-remove-OPT-or-ALT)))
+ ((and
+ (memq 'numerical-fields format)
+ (progn
+ (goto-char begin-text)
+ (looking-at "\\(\"[0-9]+\"\\)\\|\\({[0-9]+}\\)")))
+ (goto-char end-text)
+ (delete-char -1)
+ (goto-char begin-text)
+ (delete-char 1))
+ (t
+ (if (memq 'delimiters format)
+ (bibtex-format-field-delimiters begin-text end-text))
+ (if (and
+ (memq 'page-dashes format)
+ (string-match "^\\(OPT\\)?pages$" (downcase field-name))
+ (progn
+ (goto-char begin-text)
+ (looking-at
+ "\\([\"{][0-9]+\\)[ \t\n]*--?[ \t\n]*\\([0-9]+[\"}]\\)")))
+ (replace-match "\\1-\\2"))
+ (if (and
+ (memq 'inherit-booktitle format)
+ (equal (downcase field-name) "booktitle")
+ (progn
+ (goto-char begin-text)
+ (looking-at "\\(\"\"\\)\\|\\({}\\)"))
+ crossref-there
+ (not (bibtex-find-entry-location crossref-there t)))
+ ;; booktitle field empty and crossref entry found
+ ;; --> insert title field of crossreferenced entry if there
+ (let ((stop (bibtex-end-of-entry)))
+ (bibtex-beginning-of-entry)
+ (let ((bounds (bibtex-search-forward-field "title" stop)))
+ (if bounds
+ (progn
+ (goto-char begin-text)
+ (forward-char)
+ (insert
+ (buffer-substring-no-properties
+ (1+ (bibtex-start-of-text-in-field bounds))
+ (1- (bibtex-end-of-text-in-field bounds)))))))))
+ (if (progn
+ (goto-char begin-text)
+ (looking-at "\\(\"\"\\)\\|\\({}\\)"))
+ ;; if empty field, complain
+ (progn
+ (forward-char)
+ (if (or (and
+ crossref-there
+ (assoc-ignore-case
+ field-name creq))
+ (and
+ (not crossref-there)
+ (assoc-ignore-case
+ field-name req)))
+ (error
+ "Mandatory field ``%s'' is empty" field-name))))
+ (if (memq 'unify-case format)
+ (let* ((fl
+ (car (cdr (assoc-ignore-case
+ entry-type
+ bibtex-entry-field-alist))))
+ (field-list
+ (append
+ (elt fl 0)
+ (elt fl 1)
+ bibtex-user-optional-fields))
+ (new-field-name
+ (car
+ (assoc-ignore-case field-name field-list))))
+ (goto-char begin-name)
+ (if new-field-name
+ (progn
+ (delete-region begin-name end-name)
+ (insert new-field-name))
+ (downcase-region begin-name end-name))))
+ (setq field-done t)))
+ (if (not field-done)
+ (goto-char begin-field)
+ (setq field-done nil)
+ (goto-char end-field)))
+ (setq bounds (bibtex-search-forward-field bibtex-field-name end))))
+ (if (looking-at (bibtex-field-right-delimiter))
+ (forward-char))
+ (if (memq 'last-comma format)
+ (cond ((and
+ bibtex-comma-after-last-field
+ (not (looking-at ",")))
+ (insert ","))
+ ((and
+ (not bibtex-comma-after-last-field)
+ (looking-at ","))
+ (delete-char 1))))
+ (if (looking-at ",")
+ (forward-char))
+ (if (memq 'delimiters format)
+ (progn
+ (skip-chars-forward " \t\n")
+ (delete-char 1)
+ (insert (bibtex-entry-right-delimiter))))
+ (if (memq 'realign format)
+ (bibtex-fill-entry)))))))
+
+(defun bibtex-autokey-change (string change-list)
+ ;; Returns a string where some regexps are changed according to
+ ;; change-list. Every item of change-list is an (old-regexp
+ ;; new-string) pair.
+ (let* (case-fold-search
+ (return-string string)
+ (index 0)
+ (len (length change-list))
+ change-item)
+ (while (< index len)
+ (setq change-item (elt change-list index))
+ (while (string-match (car change-item) return-string)
+ (setq
+ return-string
+ (concat (substring return-string 0 (match-beginning 0))
+ (elt change-item 1)
+ (substring return-string (match-end 0)))))
+ (setq index (1+ index)))
+ return-string))
+
+(defun bibtex-autokey-abbrev (string len)
+ ;; Returns an abbreviation of string with at least len
+ ;; characters. String is aborted only after a consonant or at the
+ ;; word end. If len is not a number, string is returned unchanged.
+ (cond ((or
+ (not (numberp len))
+ (<= (length string) len))
+ string)
+ ((equal len 0)
+ "")
+ (t
+ (let* ((case-fold-search t)
+ (abort-char
+ (string-match "[^aeiou]" string (1- len))))
+ (if abort-char
+ (substring string 0 (1+ abort-char))
+ string)))))
+
+(defun bibtex-autokey-get-namefield (min max)
+ ;; returns the contents of the name field of the current entry
+ ;; does some modifications based on `bibtex-autokey-name-change-strings'
+ ;; and removes newlines unconditionally
+ (goto-char min)
+ (let* ((case-fold-search t)
+ (author-or-editor "\\(author\\)\\|\\(editor\\)")
+ (bounds (bibtex-search-forward-field author-or-editor max)))
+ (if bounds
+ (bibtex-autokey-change
+ (buffer-substring-no-properties
+ (1+ (bibtex-start-of-text-in-field bounds))
+ (1- (bibtex-end-of-text-in-field bounds)))
+ (append bibtex-autokey-name-change-strings '(("\n" " "))))
+ "")))
+
+(defun bibtex-autokey-get-names (namefield)
+ ;; gathers all names in namefield into a list
+ (let* ((case-fold-search t)
+ names)
+ (while (not (equal namefield ""))
+ (let (name)
+ (if (string-match "[ \t\n]and[ \t\n]" namefield)
+ (setq name (substring namefield 0 (match-beginning 0))
+ namefield (substring namefield (match-end 0)))
+ (setq name namefield
+ namefield ""))
+ (setq names (append names (list name)))))
+ names))
+
+(defun bibtex-autokey-demangle-name (fullname)
+ ;; gets the `last' part from a well-formed name
+ (let* (case-fold-search
+ (lastname
+ (if (string-match "," fullname)
+ ;; name is of the form "von Last, First" or
+ ;; "von Last, Jr, First"
+ ;; --> take only the part before the comma
+ (let ((von-last
+ (substring fullname 0 (match-beginning 0))))
+ (if (string-match "^[a-z]" von-last)
+ ;; von-last has a "von" part --> take the "last" part
+ (if (string-match "[ \t][A-Z]" von-last)
+ (substring von-last (1+ (match-beginning 0)))
+ (error
+ "Name %s is incorrectly formed" fullname))
+ ;; von-last has no "von" part --> take all
+ von-last))
+ ;; name is of the form "First von Last"
+ (if (string-match "[ \t]" fullname)
+ ;; more than one token
+ (if (string-match "[ \t][a-z]" fullname)
+ ;; there is a "von" part
+ ;; --> take everything after that
+ (if (string-match
+ "[ \t][A-Z]" fullname (match-end 0))
+ (substring fullname (1+ (match-beginning 0)))
+ (error
+ "Name %s is incorrectly formed" fullname))
+ ;; there is no "von" part --> take only the last token
+ (if (string-match " [^ ]*$" fullname)
+ (substring fullname (1+ (match-beginning 0)))
+ (error "Name %s is incorrectly formed" fullname)))
+ ;; only one token --> take it
+ fullname)))
+ (usename
+ (if (string-match "[ \t]+" lastname)
+ ;; lastname consists of two or more tokens
+ ;; --> take only the first one
+ (substring lastname 0 (match-beginning 0))
+ lastname)))
+ (funcall bibtex-autokey-name-case-convert usename)))
+
+(defun bibtex-autokey-get-namelist (namefield)
+ ;; gets namefield, performs abbreviations on the last parts, and
+ ;; return results as a list
+ (mapcar
+ (lambda (fullname)
+ (setq
+ fullname (substring fullname (string-match "[^ \t]" fullname)))
+ (bibtex-autokey-abbrev
+ (bibtex-autokey-demangle-name fullname)
+ bibtex-autokey-name-length))
+ (bibtex-autokey-get-names namefield)))
+
+(defun bibtex-autokey-get-yearfield-digits (max)
+ ;; get digit substring from year field.
+ (let ((bounds (bibtex-search-forward-field "year" max)))
+ (if bounds
+ (let ((year (buffer-substring-no-properties
+ (bibtex-start-of-text-in-field bounds)
+ (bibtex-end-of-text-in-field bounds))))
+ (string-match "[^0-9]*\\([0-9]+\\)" year)
+ (substring year (match-beginning 1) (match-end 1)))
+ "")))
+
+(defun bibtex-autokey-get-yearfield (min max)
+ ;; get year field from current or maybe crossreferenced entry
+ (goto-char min)
+ (let* ((case-fold-search t)
+ (year (bibtex-autokey-get-yearfield-digits max)))
+ (if (and (string= year "") bibtex-autokey-year-use-crossref-entry)
+ (let* ((bounds
+ (bibtex-search-forward-field "\\(OPT\\)?crossref" max))
+ (crossref-field
+ (if bounds
+ (buffer-substring-no-properties
+ (1+ (bibtex-start-of-text-in-field bounds))
+ (1- (bibtex-end-of-text-in-field bounds))))))
+ (if (not (bibtex-find-entry-location crossref-field t))
+ (let ((stop (bibtex-end-of-entry)))
+ (bibtex-beginning-of-entry)
+ (bibtex-autokey-get-yearfield-digits stop))
+ ""))
+ year)))
+
+(defun bibtex-autokey-get-titlestring (min max)
+ ;; get title field contents up to a terminator
+ (goto-char min)
+ (let* ((case-fold-search t)
+ (bounds (bibtex-search-forward-field "title" max))
+ (titlefield
+ (if bounds
+ (bibtex-autokey-change
+ (buffer-substring-no-properties
+ (1+ (bibtex-start-of-text-in-field bounds))
+ (1- (bibtex-end-of-text-in-field bounds)))
+ bibtex-autokey-titleword-change-strings)
+ ""))
+ (title-terminators bibtex-autokey-title-terminators))
+ (while (not (null title-terminators))
+ (if (string-match (car title-terminators) titlefield)
+ (setq titlefield (substring titlefield 0 (match-beginning 0))))
+ (setq title-terminators (cdr title-terminators)))
+ titlefield))
+
+(defun bibtex-autokey-get-titles (titlestring)
+ ;; gathers words from titlestring into a list. Ignores
+ ;; specific words and uses only a specific amount of words.
+ (let* (case-fold-search
+ titlewords
+ titlewords-extra
+ (counter 0))
+ (while (and
+ (not (equal titlestring ""))
+ (or
+ (not (numberp bibtex-autokey-titlewords))
+ (< counter
+ (+ bibtex-autokey-titlewords
+ bibtex-autokey-titlewords-stretch))))
+ (if (string-match "\\b\\w+" titlestring)
+ (let* ((end-match (match-end 0))
+ (titleword
+ (substring titlestring (match-beginning 0) end-match)))
+ (if (bibtex-member-of-regexp
+ titleword
+ bibtex-autokey-titleword-ignore)
+ (setq counter (1- counter))
+ (setq
+ titleword
+ (funcall bibtex-autokey-titleword-case-convert titleword))
+ (if (or (not (numberp bibtex-autokey-titlewords))
+ (< counter bibtex-autokey-titlewords))
+ (setq titlewords (append titlewords (list titleword)))
+ (setq titlewords-extra
+ (append titlewords-extra (list titleword)))))
+ (setq
+ titlestring (substring titlestring end-match)))
+ (setq titlestring ""))
+ (setq counter (1+ counter)))
+ (if (string-match "\\b\\w+" titlestring)
+ titlewords
+ (append titlewords titlewords-extra))))
+
+(defun bibtex-autokey-get-titlelist (titlestring)
+ ;; returns all words in titlestring as a list
+ ;; does some abbreviation on the found words
+ (mapcar
+ (lambda (titleword)
+ (let ((abbrev
+ (bibtex-assoc-of-regexp
+ titleword bibtex-autokey-titleword-abbrevs)))
+ (if abbrev
+ (elt abbrev 1)
+ (bibtex-autokey-abbrev
+ titleword
+ bibtex-autokey-titleword-length))))
+ (bibtex-autokey-get-titles titlestring)))
+
+(defun bibtex-generate-autokey ()
+ "Generates automatically a key from the author/editor and the title field.
+This will only work for entries where each field begins on a separate line.
+The generation algorithm works as follows:
+ 1. Use the value of `bibtex-autokey-prefix-string' as a prefix.
+ 2. If there is a non-empty author (preferred) or editor field,
+ use it as the name part of the key.
+ 3. Change any substring found in
+ `bibtex-autokey-name-change-strings' to the corresponding new
+ one (see documentation of this variable for further detail).
+ 4. For every of at least first `bibtex-autokey-names' names in
+ the name field, determine the last name. If there are maximal
+ `bibtex-autokey-names' + `bibtex-autokey-names-stretch'
+ names, all names are used.
+ 5. From every last name, take at least
+ `bibtex-autokey-name-length' characters (abort only after a
+ consonant or at a word end).
+ 6. Convert all last names according to the conversion function
+ `bibtex-autokey-name-case-convert'.
+ 7. Build the name part of the key by concatenating all
+ abbreviated last names with the string
+ `bibtex-autokey-name-separator' between any two. If there are
+ more names than are used in the name part, prepend the string
+ contained in `bibtex-autokey-additional-names'.
+ 8. Build the year part of the key by truncating the contents of
+ the year field to the rightmost `bibtex-autokey-year-length'
+ digits (useful values are 2 and 4). If the year field is
+ absent, but the entry has a valid crossref field and the
+ variable `bibtex-autokey-year-use-crossref-entry' is non-nil,
+ use the year field of the crossreferenced entry instead.
+ 9. For the title part of the key change the contents of the
+ title field of the entry according to
+ `bibtex-autokey-titleword-change-strings' to the
+ corresponding new one (see documentation of this variable for
+ further detail).
+10. Abbreviate the result to the string up to (but not including)
+ the first occurrence of a regexp matched by the items of
+ `bibtex-autokey-title-terminators' and delete those words which
+ appear in `bibtex-autokey-titleword-ignore'.
+ Build the title part of the key by using at least the first
+ `bibtex-autokey-titlewords' words from this
+ abbreviated title. If the abbreviated title ends after
+ maximal `bibtex-autokey-titlewords' +
+ `bibtex-autokey-titlewords-stretch' words, all
+ words from the abbreviated title are used.
+11. Convert all used titlewords according to the conversion function
+ `bibtex-autokey-titleword-case-convert'.
+12. For every used title word that appears in
+ `bibtex-autokey-titleword-abbrevs' use the corresponding
+ abbreviation (see documentation of this variable for further
+ detail).
+13. From every title word not generated by an abbreviation, take
+ at least `bibtex-autokey-titleword-length' characters (abort
+ only after a consonant or at a word end).
+14. Build the title part of the key by concatenating all
+ abbreviated title words with the string
+ `bibtex-autokey-titleword-separator' between any two.
+15. At least, to get the key, concatenate
+ `bibtex-autokey-prefix-string', the name part, the year part
+ and the title part with `bibtex-autokey-name-year-separator'
+ between the name part and the year part if both are non-empty
+ and `bibtex-autokey-year-title-separator' between the year
+ part and the title part if both are non-empty. If the year
+ part is empty, but not the other two parts,
+ `bibtex-autokey-year-title-separator' is used as well.
+16. If the value of `bibtex-autokey-before-presentation-function'
+ is non-nil, it must be a function taking one argument. This
+ function is then called with the generated key as the
+ argument. The return value of this function (a string) is
+ used as the key.
+17. If the value of `bibtex-autokey-edit-before-use' is non-nil,
+ the key is then presented in the minibuffer to the user,
+ where it can be edited. The key given by the user is then
+ used."
+ (let* ((pnt (point))
+ (min (bibtex-beginning-of-entry))
+ (max (bibtex-end-of-entry))
+ (namefield (bibtex-autokey-get-namefield min max))
+ (name-etal "")
+ (namelist
+ (let ((nl (bibtex-autokey-get-namelist namefield)))
+ (if (or (not (numberp bibtex-autokey-names))
+ (<= (length nl)
+ (+ bibtex-autokey-names
+ bibtex-autokey-names-stretch)))
+ nl
+ (setq name-etal bibtex-autokey-additional-names)
+ (let (nnl)
+ (while (< (length nnl) bibtex-autokey-names)
+ (setq nnl (append nnl (list (car nl)))
+ nl (cdr nl)))
+ nnl))))
+ (namepart
+ (concat
+ (mapconcat (lambda (name) name)
+ namelist
+ bibtex-autokey-name-separator)
+ name-etal))
+ (yearfield (bibtex-autokey-get-yearfield min max))
+ (yearpart
+ (if (equal yearfield "")
+ ""
+ (substring
+ yearfield
+ (- (length yearfield) bibtex-autokey-year-length))))
+ (titlestring (bibtex-autokey-get-titlestring min max))
+ (titlelist (bibtex-autokey-get-titlelist titlestring))
+ (titlepart
+ (mapconcat
+ (lambda (name) name)
+ titlelist
+ bibtex-autokey-titleword-separator))
+ (autokey
+ (concat
+ bibtex-autokey-prefix-string
+ namepart
+ (if (not
+ (or
+ (equal namepart "")
+ (equal yearpart "")))
+ bibtex-autokey-name-year-separator)
+ yearpart
+ (if (not
+ (or
+ (and
+ (equal namepart "")
+ (equal yearpart ""))
+ (equal titlepart "")))
+ bibtex-autokey-year-title-separator)
+ titlepart)))
+ (if bibtex-autokey-before-presentation-function
+ (setq
+ autokey
+ (funcall bibtex-autokey-before-presentation-function autokey)))
+ (goto-char pnt)
+ autokey))
+
+(defun bibtex-parse-keys (add verbose &optional abortable)
+ ;; Sets bibtex-reference-keys to the keys used in the whole (possibly
+ ;; restricted) buffer (either as entry keys or as crossref entries).
+ ;; If ADD is non-nil adds the new keys to bibtex-reference-keys instead of
+ ;; simply resetting it. If VERBOSE is non-nil gives messages about
+ ;; progress. If ABORTABLE is non-nil abort on user input.
+ (if bibtex-maintain-sorted-entries
+ (let* ((case-fold-search t)
+ (reference-keys (if add bibtex-reference-keys)))
+ (save-excursion
+ (goto-char (point-min))
+ (if verbose
+ (bibtex-progress-message
+ (concat (buffer-name) ": parsing reference keys")))
+ (if (catch 'userkey
+ (bibtex-skip-to-valid-entry)
+ (while (not (eobp))
+ (if (and
+ abortable
+ (input-pending-p))
+ (throw 'userkey t))
+ (if verbose
+ (bibtex-progress-message))
+ (let (reference-key
+ xrefd-reference-key)
+ (cond
+ ((looking-at bibtex-entry-head)
+ (setq
+ reference-key
+ (buffer-substring-no-properties
+ (match-beginning bibtex-key-in-head)
+ (match-end bibtex-key-in-head)))
+ (let ((p (point))
+ (m (bibtex-end-of-entry)))
+ (goto-char p)
+ (let ((bounds (bibtex-search-forward-field "crossref" m)))
+ (if bounds
+ (setq
+ xrefd-reference-key
+ (buffer-substring-no-properties
+ (1+ (bibtex-start-of-text-in-field bounds))
+ (1- (bibtex-end-of-text-in-field bounds))))))))
+ ((bibtex-parse-string)
+ (let ((bounds (bibtex-parse-string)))
+ (setq
+ reference-key
+ (buffer-substring-no-properties
+ (bibtex-start-of-reference-key-in-string bounds)
+ (bibtex-end-of-reference-key-in-string bounds))))))
+ (forward-char)
+ (bibtex-skip-to-valid-entry)
+ (if (not (assoc reference-key reference-keys))
+ (setq reference-keys
+ (cons (list reference-key) reference-keys)))
+ (if (and xrefd-reference-key
+ (not (assoc xrefd-reference-key reference-keys)))
+ (setq reference-keys
+ (cons (list xrefd-reference-key) reference-keys))))))
+ ;; user has aborted by typing a key --> return nil
+ nil
+ ;; successful operation --> return t
+ (setq
+ bibtex-buffer-last-parsed-tick (buffer-modified-tick)
+ bibtex-reference-keys reference-keys)
+ (if verbose
+ (bibtex-progress-message 'done))
+ t)))))
+
+(defun bibtex-parse-buffers-stealthily ()
+ ;; Called by bibtex-run-with-idle-timer. Whenever emacs has been idle
+ ;; for bibtex-parse-keys-timeout seconds, all BibTeX buffers (starting
+ ;; with the current) are parsed.
+ (let ((buffers (buffer-list)))
+ (save-excursion
+ (while (and buffers (not (input-pending-p)))
+ (set-buffer (car buffers))
+ (save-restriction
+ (widen)
+ (if (and
+ (eq major-mode 'bibtex-mode)
+ bibtex-maintain-sorted-entries
+ (not
+ (eq (buffer-modified-tick)
+ bibtex-buffer-last-parsed-tick)))
+ (if (bibtex-parse-keys nil t t)
+ ;; successful operation --> remove buffer from list
+ (setq buffers (cdr buffers)))
+ ;; buffer is no BibTeX buffer or needs no parsing
+ (setq buffers (cdr buffers))))))))
+
+(defun bibtex-complete (string-list &optional complete-strings)
+ ;; Complete word fragment before point to longest prefix of one
+ ;; string defined in STRING-LIST. If point is not after the part of
+ ;; a word, all strings are listed. If COMPLETE-STRINGS is non-nil,
+ ;; add the strings defined in this buffer before cursor to
+ ;; STRING-LIST and remove surrounding delimiters if complete string
+ ;; could be expanded.
+ (let* ((case-fold-search t)
+ (end (point))
+ (beg (save-excursion
+ (re-search-backward "[ \t{\"]")
+ (forward-char)
+ (point)))
+ (part-of-word (buffer-substring-no-properties beg end))
+ (completions (copy-sequence string-list))
+ (completion (save-excursion
+ (if complete-strings
+ (while (bibtex-search-backward-string)
+ (let ((bounds (bibtex-search-backward-string)))
+ (setq completions
+ (cons
+ (list
+ (buffer-substring-no-properties
+ (bibtex-start-of-reference-key-in-string bounds)
+ (bibtex-end-of-reference-key-in-string bounds)))
+ completions)))))
+ (setq completions
+ (sort completions
+ (lambda(x y)
+ (string-lessp
+ (car x)
+ (car y)))))
+ (try-completion part-of-word completions))))
+ (cond ((eq completion t)
+ (if complete-strings
+ ;; remove double-quotes or braces if field is no concatenation
+ (save-excursion
+ (bibtex-inside-field)
+ (let* ((bounds (bibtex-enclosing-field)))
+ (goto-char (bibtex-start-of-text-in-field bounds))
+ (let ((boundaries (bibtex-parse-field-string)))
+ (if (and boundaries (equal (cdr boundaries) (bibtex-end-of-text-in-field bounds)))
+ (bibtex-remove-delimiters)))))))
+ ((not completion)
+ (error "Can't find completion for \"%s\"" part-of-word))
+ ((not (string= part-of-word completion))
+ (delete-region beg end)
+ (insert completion)
+ (if (and (assoc completion completions)
+ complete-strings)
+ ;; remove double-quotes or braces if field is no concatenation
+ (save-excursion
+ (bibtex-inside-field)
+ (let* ((bounds (bibtex-enclosing-field)))
+ (goto-char (bibtex-start-of-text-in-field bounds))
+ (let ((boundaries (bibtex-parse-field-string)))
+ (if (and boundaries (equal (cdr boundaries) (bibtex-end-of-text-in-field bounds)))
+ (bibtex-remove-delimiters)))))))
+ (t
+ (message "Making completion list...")
+ (let ((list (all-completions part-of-word completions)))
+ (with-output-to-temp-buffer "*Completions*"
+ (display-completion-list list)))
+ (message "Making completion list...done")))))
+
+(defun bibtex-do-auto-fill ()
+ (let ((fill-prefix
+ (make-string
+ (+ bibtex-entry-offset bibtex-contline-indentation) ? )))
+ (do-auto-fill)))
+
+(defun bibtex-pop (arg direction)
+ ;; generic function to be used by bibtex-pop-previous and bibtex-pop-next
+ (let (bibtex-help-message)
+ (bibtex-find-text nil))
+ (save-excursion
+ ;; parse current field
+ (bibtex-inside-field)
+ (let* ((case-fold-search t)
+ (bounds (bibtex-enclosing-field))
+ (start-old-text (bibtex-start-of-text-in-field bounds))
+ (stop-old-text (bibtex-end-of-text-in-field bounds))
+ (start-name (bibtex-start-of-name-in-field bounds))
+ (stop-name (bibtex-end-of-name-in-field bounds))
+ (new-text))
+ (goto-char start-name)
+ ;; construct regexp for field with same name as this one,
+ ;; ignoring possible OPT's or ALT's
+ (let* ((field-name
+ (buffer-substring-no-properties
+ (if (looking-at "\\(OPT\\)\\|\\(ALT\\)")
+ (match-end 0)
+ (point))
+ stop-name)))
+ ;; if executed several times in a row, start each search where
+ ;; the last one was finished
+ (cond ((eq last-command 'bibtex-pop) t)
+ (t
+ (bibtex-enclosing-entry-maybe-empty-head)
+ (setq
+ bibtex-pop-previous-search-point (match-beginning 0)
+ bibtex-pop-next-search-point (point))))
+ (if (eq direction 'previous)
+ (goto-char bibtex-pop-previous-search-point)
+ (goto-char bibtex-pop-next-search-point))
+ ;; Now search for arg'th previous/next similar field
+ (let ((bounds nil)
+ (failure nil))
+ (while (and (not failure) (> arg 0))
+ (cond ((eq direction 'previous)
+ (setq bounds (bibtex-search-backward-field field-name (point-min)))
+ (if bounds
+ (goto-char (bibtex-start-of-field bounds))
+ (setq failure t)))
+ ((eq direction 'next)
+ (setq bounds (bibtex-search-forward-field field-name (point-max)))
+ (if bounds
+ (goto-char (bibtex-end-of-field bounds))
+ (setq failure t))))
+ (setq arg (- arg 1)))
+ (if failure
+ (error (if (eq direction 'previous)
+ "No previous matching BibTeX field."
+ "No next matching BibTeX field."))
+ ;; Found a matching field. Remember boundaries.
+ (setq bibtex-pop-previous-search-point (bibtex-start-of-field bounds))
+ (setq bibtex-pop-next-search-point (bibtex-end-of-field bounds))
+ (setq new-text
+ (buffer-substring-no-properties
+ (bibtex-start-of-text-in-field bounds)
+ (bibtex-end-of-text-in-field bounds)))
+ (bibtex-flash-head)
+ ;; Go back to where we started, delete old text, and pop new.
+ (goto-char stop-old-text)
+ (delete-region start-old-text stop-old-text)
+ (insert new-text))))))
+ (let (bibtex-help-message)
+ (bibtex-find-text nil))
+ (setq this-command 'bibtex-pop))
+
+\f
+;; Interactive Functions:
+
+;;;###autoload
+(defun bibtex-mode ()
+ "Major mode for editing BibTeX files.
+
+To submit a problem report, enter \\[bibtex-submit-bug-report] from a
+BibTeX mode buffer. This automatically sets up a mail buffer with
+version information already added. You just need to add a description
+of the problem, including a reproducible test case and send the
+message.
+
+
+General information on working with BibTeX mode:
+
+You should use commands as \\[bibtex-Book] to get a template for a
+specific entry. You should then fill in all desired fields using
+\\[bibtex-next-field] to jump from field to field. After having filled
+in all desired fields in the entry, you should clean the new entry
+with command \\[bibtex-clean-entry].
+
+Some features of BibTeX mode are available only by setting variable
+bibtex-maintain-sorted-entries to t. However, then BibTeX mode will
+work with buffer containing only valid (syntactical correct) entries
+and with entries being sorted. This is usually the case, if you have
+created a buffer completely with BibTeX mode and finished every new
+entry with \\[bibtex-clean-entry].
+
+For third party BibTeX buffers, please call the function
+`bibtex-convert-alien' to fully take advantage of all features of
+BibTeX mode.
+
+
+Special information:
+
+A command such as \\[bibtex-Book] will outline the fields for a BibTeX book entry.
+
+The optional fields start with the string OPT, and are thus ignored by BibTeX.
+Alternatives from which only one is required start with the string ALT.
+The OPT or ALT string may be removed from a field with \\[bibtex-remove-OPT-or-ALT].
+\\[bibtex-make-field] inserts a new field after the current one.
+\\[bibtex-kill-field] kills the current field entirely.
+\\[bibtex-yank] will yank the last recently killed field after the
+current field.
+\\[bibtex-remove-delimiters] removes the double-quotes or braces around the text of the current field.
+ \\[bibtex-empty-field] replaces the text of the current field with the default \"\" or {}.
+
+The command \\[bibtex-clean-entry] cleans the current entry, i.e. it removes OPT/ALT
+from all non-empty optional or alternative fields, checks that no required
+fields are empty, and does some formatting dependent on the value of
+bibtex-entry-format.
+Note: some functions in BibTeX mode depend on entries being in a special
+format (all fields beginning on separate lines), so it is usually a bad
+idea to remove `realign' from bibtex-entry-format.
+
+Use \\[bibtex-find-text] to position the cursor at the end of the current field.
+Use \\[bibtex-next-field] to move to end of the next field.
+
+The following may be of interest as well:
+
+ Functions:
+ bibtex-entry
+ bibtex-kill-entry
+ bibtex-yank-pop
+ bibtex-pop-previous
+ bibtex-pop-next
+ bibtex-complete-string
+ bibtex-complete-key
+ bibtex-print-help-message
+ bibtex-generate-autokey
+ bibtex-beginning-of-entry
+ bibtex-end-of-entry
+ bibtex-reposition-window
+ bibtex-mark-entry
+ bibtex-ispell-abstract
+ bibtex-ispell-entry
+ bibtex-narrow-to-entry
+ bibtex-sort-buffer
+ bibtex-validate
+ bibtex-count
+ bibtex-fill-entry
+ bibtex-reformat
+ bibtex-convert-alien
+
+ Variables:
+ bibtex-field-delimiters
+ bibtex-include-OPTcrossref
+ bibtex-include-OPTkey
+ bibtex-user-optional-fields
+ bibtex-entry-format
+ bibtex-sort-ignore-string-entries
+ bibtex-maintain-sorted-entries
+ bibtex-entry-field-alist
+ bibtex-predefined-strings
+ bibtex-string-files
+
+---------------------------------------------------------
+Entry to BibTeX mode calls the value of `bibtex-mode-hook' if that value is
+non-nil.
+
+\\{bibtex-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map bibtex-mode-map)
+ (setq major-mode 'bibtex-mode)
+ (setq mode-name "BibTeX")
+ (set-syntax-table bibtex-mode-syntax-table)
+ (setq bibtex-strings bibtex-predefined-strings)
+ (mapcar
+ (lambda (filename)
+ ;; collect pathnames
+ (let* ((path (if bibtex-string-file-path
+ bibtex-string-file-path
+ "."))
+ (dirs (split-string path ":+"))
+ (filename (if (string-match "\.bib$" filename)
+ filename
+ (concat filename ".bib")))
+ fullfilename
+ (item 0)
+ (size (length dirs)))
+ ;; test filenames
+ (while (and
+ (< item size)
+ (not (file-readable-p
+ (setq fullfilename
+ (concat (elt dirs item) "/" filename)))))
+ (setq item (1+ item)))
+ (if (< item size)
+ ;; file was found
+ (let* ((case-fold-search t)
+ (compl nil))
+ (with-temp-buffer
+ (insert-file-contents fullfilename)
+ (goto-char (point-min))
+ (let ((bounds (bibtex-search-forward-string)))
+ (while bounds
+ (setq compl
+ (cons (list (buffer-substring-no-properties
+ (bibtex-start-of-reference-key-in-string bounds)
+ (bibtex-end-of-reference-key-in-string bounds)))
+ compl))
+ (goto-char (bibtex-end-of-string bounds))
+ (setq bounds (bibtex-search-forward-string)))))
+ (setq bibtex-strings (append bibtex-strings (nreverse compl))))
+ (error
+ "File %s not in paths defined by bibtex-string-file-path variable"
+ filename))))
+ bibtex-string-files)
+ (if bibtex-maintain-sorted-entries
+ (bibtex-run-with-idle-timer
+ 1 nil
+ (lambda ()
+ (bibtex-parse-keys nil t t))))
+ ;; to get buffer parsed once if everything else (including things
+ ;; installed in bibtex-mode-hook) has done its work
+ (if (not bibtex-parse-idle-timer)
+ (setq bibtex-parse-idle-timer
+ (bibtex-run-with-idle-timer
+ bibtex-parse-keys-timeout t
+ 'bibtex-parse-buffers-stealthily)))
+ ;; Install stealthy parse function if not already installed
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start "[ \f\n\t]*$")
+ (make-local-variable 'comment-start)
+ (setq comment-start bibtex-comment-start)
+ (make-local-variable 'comment-start-skip)
+ (setq comment-start-skip bibtex-comment-start)
+ (make-local-variable 'comment-column)
+ (setq comment-column 0)
+ (make-local-variable 'defun-prompt-regexp)
+ (setq defun-prompt-regexp "^@[a-zA-Z0-9]+")
+ (make-local-variable 'outline-regexp)
+ (setq outline-regexp "@")
+ (make-local-variable 'normal-auto-fill-function)
+ (setq normal-auto-fill-function 'bibtex-do-auto-fill)
+ (make-local-variable 'font-lock-defaults)
+ (setq font-lock-defaults
+ '(bibtex-font-lock-keywords
+ nil t ((?$ . "\"")
+ ;; Mathematical expressions should be fontified as strings
+ (?\" . ".")
+ ;; Quotes are field delimiters and quote-delimited
+ ;; entries should be fontified in the same way as
+ ;; brace-delimited ones
+ )))
+ (make-local-variable 'font-lock-mark-block-function)
+ (setq font-lock-mark-block-function
+ (lambda ()
+ (set-mark (bibtex-end-of-entry))
+ (bibtex-beginning-of-entry)))
+ (setq imenu-generic-expression
+ (list (list nil bibtex-entry-head bibtex-key-in-head)))
+ (setq imenu-case-fold-search t)
+ ;; XEmacs needs easy-menu-add, Emacs does not care
+ (easy-menu-add bibtex-edit-menu)
+ (easy-menu-add bibtex-entry-menu)
+ (run-hooks 'bibtex-mode-hook))
+
+(defun bibtex-submit-bug-report ()
+ "Submit via mail a bug report on bibtex.el."
+ (interactive)
+ (if (y-or-n-p "Do you want to submit a bug report on BibTeX mode? ")
+ (progn
+ (require 'reporter)
+ (let ((reporter-prompt-for-summary-p t))
+ (reporter-submit-bug-report
+ bibtex-maintainer-address
+ "bibtex.el"
+ (list
+ 'system-configuration
+ 'system-configuration-options
+ 'bibtex-mode-hook
+ 'bibtex-parse-keys-timeout
+ ;; possible general errors
+ 'bibtex-sort-ignore-string-entries
+ 'bibtex-maintain-sorted-entries
+ 'bibtex-entry-delimiters
+ 'bibtex-field-delimiters
+ 'bibtex-comma-after-last-field
+ 'bibtex-entry-offset
+ 'bibtex-field-indentation
+ 'bibtex-text-indentation
+ 'bibtex-contline-indentation
+ 'bibtex-align-at-equal-sign
+ ;; possible sorting and parsing bugs
+ 'bibtex-entry-format
+ 'bibtex-add-entry-hook
+ 'bibtex-clean-entry-hook
+ ;; possible cleaning error
+ 'bibtex-user-optional-fields
+ ;; possible format error
+ 'bibtex-predefined-month-strings
+ 'bibtex-predefined-strings
+ 'bibtex-string-files
+ 'bibtex-string-file-path
+ ;; possible format error
+ 'bibtex-font-lock-keywords
+ ;; possible bugs regarding fontlocking
+ 'bibtex-autokey-prefix-string
+ 'bibtex-autokey-names
+ 'bibtex-autokey-names-stretch
+ 'bibtex-autokey-additional-names
+ 'bibtex-autokey-transcriptions
+ 'bibtex-autokey-name-change-strings
+ 'bibtex-autokey-name-case-convert
+ 'bibtex-autokey-name-length
+ 'bibtex-autokey-name-separator
+ 'bibtex-autokey-year-length
+ 'bibtex-autokey-year-use-crossref-entry
+ 'bibtex-autokey-titlewords
+ 'bibtex-autokey-title-terminators
+ 'bibtex-autokey-titlewords-stretch
+ 'bibtex-autokey-titleword-ignore
+ 'bibtex-autokey-titleword-case-convert
+ 'bibtex-autokey-titleword-abbrevs
+ 'bibtex-autokey-titleword-change-strings
+ 'bibtex-autokey-titleword-length
+ 'bibtex-autokey-titleword-separator
+ 'bibtex-autokey-name-year-separator
+ 'bibtex-autokey-year-title-separator
+ 'bibtex-autokey-edit-before-use
+ 'bibtex-autokey-before-presentation-function
+ ;; possible bugs regarding automatic reference keys
+ 'bibtex-entry-field-alist
+ ;; possible format error
+ 'bibtex-help-message
+ 'bibtex-include-OPTcrossref
+ 'bibtex-include-OPTkey
+ 'bibtex-field-kill-ring-max
+ 'bibtex-entry-kill-ring-max
+ ;; user variables which shouldn't cause any errors
+ )
+ nil nil
+ (concat bibtex-maintainer-salutation "
+
+I want to report a bug on Emacs BibTeX mode.
+
+I've read the `Bugs' section in the `Emacs' info page, so I know how
+to make a clear and unambiguous report. I have started a fresh Emacs
+via `"invocation-name " --no-init-file --no-site-file', thereafter (in
+case I'm reporting on a version of `bibtex.el' which is not part of
+the standard emacs distribution) I loaded the questionable version
+of `bibtex.el' with `M-x load-file', and then, to produce the buggy
+behaviour, I did the following:")))
+ (message nil))))
+
+(defun bibtex-entry (entry-type)
+ "Insert a new BibTeX entry.
+After insertion it calls the functions in `bibtex-add-entry-hook'."
+ (interactive (let* ((completion-ignore-case t)
+ (e-t (completing-read
+ "Entry Type: "
+ bibtex-entry-field-alist
+ nil t nil 'bibtex-entry-type-history)))
+ (list e-t)))
+ (if (not bibtex-reference-keys)
+ (bibtex-parse-keys nil t))
+ (let* (required
+ optional
+ (key
+ (if bibtex-maintain-sorted-entries
+ (completing-read
+ (format "%s key: " entry-type)
+ bibtex-reference-keys nil nil nil 'bibtex-key-history)))
+ (e (assoc-ignore-case entry-type bibtex-entry-field-alist))
+ (r-n-o (elt e 1))
+ (c-ref (elt e 2)))
+ (if (not e)
+ (error "Bibtex entry type %s not defined" entry-type))
+ (if (and
+ (member entry-type bibtex-include-OPTcrossref)
+ c-ref)
+ (setq required (elt c-ref 0)
+ optional (elt c-ref 1))
+ (setq required (elt r-n-o 0)
+ optional (elt r-n-o 1)))
+ (if bibtex-maintain-sorted-entries
+ (bibtex-find-entry-location key)
+ (bibtex-move-outside-of-entry))
+ (indent-to-column bibtex-entry-offset)
+ (insert "@" entry-type (bibtex-entry-left-delimiter))
+ (if key
+ (insert key))
+ (save-excursion
+ (mapcar 'bibtex-make-field required)
+ (if (member entry-type bibtex-include-OPTcrossref)
+ (bibtex-make-optional-field '("crossref")))
+ (if bibtex-include-OPTkey
+ (if (or
+ (stringp bibtex-include-OPTkey)
+ (fboundp bibtex-include-OPTkey))
+ (bibtex-make-optional-field
+ (list "key" nil bibtex-include-OPTkey))
+ (bibtex-make-optional-field '("key"))))
+ (mapcar 'bibtex-make-optional-field optional)
+ (mapcar 'bibtex-make-optional-field bibtex-user-optional-fields)
+ (if bibtex-comma-after-last-field
+ (insert ","))
+ (insert "\n")
+ (indent-to-column bibtex-entry-offset)
+ (insert (bibtex-entry-right-delimiter) "\n\n"))
+ (bibtex-next-field t)
+ (run-hooks 'bibtex-add-entry-hook)))
+
+(defun bibtex-print-help-message ()
+ "Prints helpful information about current field in current BibTeX entry."
+ (interactive)
+ (let* ((case-fold-search t)
+ (pnt (point))
+ (field-name
+ (let* ((bounds (bibtex-enclosing-field))
+ (mb (bibtex-start-of-name-in-field bounds))
+ (me (bibtex-end-of-name-in-field bounds)))
+ (goto-char mb)
+ (buffer-substring-no-properties
+ (if (looking-at "OPT\\|ALT")
+ (+ 3 mb)
+ mb)
+ me)))
+ (entry-type
+ (progn
+ (re-search-backward
+ bibtex-entry-maybe-empty-head nil t)
+ (buffer-substring-no-properties
+ (1+ (match-beginning bibtex-type-in-head))
+ (match-end bibtex-type-in-head))))
+ (entry-list
+ (assoc-ignore-case entry-type
+ bibtex-entry-field-alist))
+ (c-r-list (elt entry-list 2))
+ (req-opt-list
+ (if (and
+ (member entry-type bibtex-include-OPTcrossref)
+ c-r-list)
+ c-r-list
+ (elt entry-list 1)))
+ (list-of-entries (append
+ (elt req-opt-list 0)
+ (elt req-opt-list 1)
+ bibtex-user-optional-fields
+ (if (member
+ entry-type
+ bibtex-include-OPTcrossref)
+ '(("crossref"
+ "Reference key of the crossreferenced entry")))
+ (if bibtex-include-OPTkey
+ '(("key"
+ "Used for reference key creation if author and editor fields are missing"))))))
+ (goto-char pnt)
+ (let ((comment (assoc-ignore-case field-name list-of-entries)))
+ (if comment
+ (message (elt comment 1))
+ (message "NO COMMENT AVAILABLE")))))
+
+(defun bibtex-make-field (e-t &optional called-by-yank)
+ "Makes a field named E-T in current BibTeX entry.
+This function is for interactive and non-interactive purposes. To call
+it interactively, just give it no arguments and enter the field name
+using the minibuffer."
+ (interactive "*P")
+ (if (not e-t)
+ (setq
+ e-t
+ (let* ((entry-type
+ (save-excursion
+ (bibtex-enclosing-entry-maybe-empty-head)
+ (buffer-substring-no-properties
+ (1+ (match-beginning bibtex-type-in-head))
+ (match-end bibtex-type-in-head))))
+ (fl
+ (car (cdr (assoc-ignore-case
+ entry-type bibtex-entry-field-alist))))
+ (field-list
+ (append
+ (elt fl 0) (elt fl 1) bibtex-user-optional-fields
+ (if bibtex-include-OPTcrossref '(("crossref" nil)))
+ (if bibtex-include-OPTkey '(("key" nil)))))
+ (completion-ignore-case t))
+ (completing-read
+ "BibTeX field name: " field-list
+ nil nil nil bibtex-field-history))))
+ (if (not (consp e-t))
+ (setq e-t (list e-t)))
+ (if (equal (length e-t) 1)
+ (setq e-t (append e-t (list ""))))
+ (if (equal (length e-t) 2)
+ (setq e-t (append e-t (list ""))))
+ (let ((name (if (elt e-t 3)
+ (concat "ALT" (car e-t))
+ (car e-t))))
+ (if (or (interactive-p) called-by-yank)
+ (let (bibtex-help-message)
+ (bibtex-find-text nil t)
+ (if (looking-at "[}\"]")
+ (forward-char))))
+ (insert ",\n")
+ (indent-to-column
+ (+ bibtex-entry-offset bibtex-field-indentation))
+ (insert name " ")
+ (if bibtex-align-at-equal-sign
+ (indent-to-column
+ (+ bibtex-entry-offset (- bibtex-text-indentation 2))))
+ (insert "= ")
+ (if (not bibtex-align-at-equal-sign)
+ (indent-to-column
+ (+ bibtex-entry-offset bibtex-text-indentation)))
+ (insert (if called-by-yank
+ ""
+ (bibtex-field-left-delimiter))
+ (let ((init (elt e-t 2)))
+ (cond
+ ((stringp init)
+ init)
+ ((fboundp init)
+ (funcall init))
+ (t
+ (error "%s is neither a string nor a function" init))))
+ (if called-by-yank
+ ""
+ (bibtex-field-right-delimiter)))
+ (if (interactive-p)
+ (forward-char -1))))
+
+(defun bibtex-beginning-of-entry ()
+ "Move to beginning of BibTeX entry.
+If inside an entry, move to the beginning of it, otherwise move to the
+beginning of the previous entry.
+If called from a program, this function returns the new location of point."
+ (interactive)
+ (skip-chars-forward " \t")
+ (if (looking-at "@")
+ (forward-char))
+ (re-search-backward "^[ \t]*@" nil 'move))
+
+(defun bibtex-end-of-entry ()
+ "Move to end of BibTeX entry.
+If inside an entry, move to the end of it, otherwise move to the end
+of the previous entry.
+If called from a program, this function returns the new location of point."
+ (interactive)
+ (let* ((case-fold-search t)
+ (valid-entry-head
+ (concat "[ \t]*@[ \t]*\\("
+ (mapconcat
+ (lambda (type)
+ (concat "\\(" (car type) "\\)"))
+ bibtex-entry-field-alist
+ "\\|")
+ "\\)"))
+ (org (point))
+ (pnt (bibtex-beginning-of-entry))
+ err)
+ (cond
+ ((bibtex-parse-string)
+ (let ((bounds (bibtex-parse-string)))
+ (goto-char (bibtex-end-of-string bounds))))
+ ((looking-at "[ \t]*@[ \t]*preamble[ \t\n]*")
+ (goto-char (match-end 0))
+ (cond
+ ((looking-at "(")
+ (if (not (re-search-forward ")[ \t]*\n\n" nil 'move))
+ (setq err t)))
+ ((looking-at "{")
+ (if (not (re-search-forward "}[ \t]*\n\n" nil 'move))
+ (setq err t)))
+ (t
+ (setq err t)))
+ (if (not err)
+ (progn
+ (goto-char (match-beginning 0))
+ (forward-char))))
+ ((looking-at valid-entry-head)
+ (bibtex-search-entry t nil t)
+ (if (not (equal (match-beginning 0) pnt))
+ (setq err t)))
+ (t
+ (if (interactive-p)
+ (message "Not on a known BibTeX entry."))
+ (goto-char org)))
+ (if err
+ (progn
+ (goto-char pnt)
+ (error "Syntactical incorrect entry starts here"))))
+ (point))
+
+(defun bibtex-reposition-window (arg)
+ "Make the current BibTeX entry visible."
+ (interactive "P")
+ (save-excursion
+ (goto-char
+ (/ (+ (bibtex-beginning-of-entry) (bibtex-end-of-entry)) 2))
+ (recenter arg)))
+
+(defun bibtex-mark-entry ()
+ "Put mark at beginning, point at end of current BibTeX entry."
+ (interactive)
+ (set-mark (bibtex-beginning-of-entry))
+ (bibtex-end-of-entry))
+
+(defun bibtex-count-entries (&optional count-string-entries)
+ "Count number of entries in current buffer or region.
+With prefix argument COUNT-STRING-ENTRIES it counts all entries,
+otherwise it counts all except Strings.
+If mark is active it counts entries in region, if not in whole buffer."
+ (interactive "P")
+ (let ((pnt (point))
+ (start-point
+ (if (bibtex-mark-active)
+ (region-beginning)
+ (bibtex-beginning-of-first-entry)))
+ (end-point
+ (if (bibtex-mark-active)
+ (region-end)
+ (point-max)))
+ (number 0)
+ (bibtex-sort-ignore-string-entries
+ (not count-string-entries)))
+ (save-restriction
+ (narrow-to-region start-point end-point)
+ (goto-char start-point)
+ (bibtex-map-entries
+ (lambda (current)
+ (setq number (1+ number)))))
+ (message (concat (if (bibtex-mark-active) "Region" "Buffer")
+ " contains %d entries.") number)
+ (goto-char pnt)))
+
+(defun bibtex-ispell-entry ()
+ "Spell whole BibTeX entry."
+ (interactive)
+ (ispell-region (bibtex-beginning-of-entry) (bibtex-end-of-entry)))
+
+(defun bibtex-ispell-abstract ()
+ "Spell abstract of BibTeX entry."
+ (interactive)
+ (let* ((case-fold-search t)
+ (pnt (bibtex-end-of-entry)))
+ (bibtex-beginning-of-entry)
+ (let ((bounds (bibtex-search-forward-field "abstract" pnt)))
+ (if bounds
+ (ispell-region (bibtex-start-of-text-in-field bounds) (bibtex-end-of-text-in-field bounds))
+ (error "No abstract in entry")))))
+
+(defun bibtex-narrow-to-entry ()
+ "Narrow buffer to current BibTeX entry."
+ (interactive)
+ (save-excursion
+ (narrow-to-region
+ (bibtex-beginning-of-entry) (bibtex-end-of-entry))))
+
+(defun bibtex-sort-buffer ()
+ "Sort BibTeX buffer alphabetically by key.
+Text outside of BibTeX entries is not affected. If
+`bibtex-sort-ignore-string-entries' is non-nil, @String entries will be
+ignored."
+ (interactive)
+ (save-restriction
+ (narrow-to-region
+ (bibtex-beginning-of-first-entry)
+ (save-excursion
+ (goto-char (point-max))
+ (bibtex-end-of-entry)))
+ (bibtex-skip-to-valid-entry)
+ (sort-subr
+ nil
+ ;; NEXTREC function
+ 'bibtex-skip-to-valid-entry
+ ;; ENDREC function
+ 'bibtex-end-of-entry
+ ;; STARTKEY function
+ (lambda ()
+ (let* ((case-fold-search t))
+ (re-search-forward bibtex-entry-head)
+ (buffer-substring-no-properties
+ (match-beginning bibtex-key-in-head)
+ (match-end bibtex-key-in-head)))))))
+
+(defun bibtex-find-entry-location (entry-name &optional ignore-dups)
+ "Looking for place to put the BibTeX entry named ENTRY-NAME.
+Performs a binary search (therefore, buffer is assumed to be in sorted
+order, without duplicates (see \\[bibtex-validate]), if it is
+not, `bibtex-find-entry-location' will fail). If entry-name is already
+used as a reference key, an error is signaled. However, if optional
+variable IGNORE-DUPS is non-nil, no error messages about duplicate
+entries are signaled, but the error handling is assumed to be made in
+the calling function.
+The value is nil if a duplicate entry error occurred,
+and t in all other cases."
+ (let* ((case-fold-search t)
+ (left
+ (progn
+ (bibtex-beginning-of-first-entry)
+ (bibtex-skip-to-valid-entry)
+ (bibtex-end-of-entry)))
+ (right
+ (progn
+ (bibtex-beginning-of-last-entry)
+ (bibtex-skip-to-valid-entry t)
+ (point)))
+ actual-point
+ actual-key
+ (done (>= left right))
+ new
+ dup)
+ (while (not done)
+ (setq actual-point (/ (+ left right) 2))
+ (goto-char actual-point)
+ (bibtex-skip-to-valid-entry t)
+ (setq actual-key
+ (progn
+ (re-search-forward bibtex-entry-head)
+ (buffer-substring-no-properties
+ (match-beginning bibtex-key-in-head)
+ (match-end bibtex-key-in-head))))
+ (cond
+ ((string-lessp entry-name actual-key)
+ (setq new (bibtex-beginning-of-entry))
+ (if (equal right new)
+ (setq done t)
+ (setq right new)))
+ ((string-lessp actual-key entry-name)
+ (setq new (bibtex-end-of-entry))
+ (if (equal left new)
+ (setq done t)
+ (setq left new)))
+ ((string-equal actual-key entry-name)
+ (setq dup t
+ done t)
+ (if (not ignore-dups)
+ (progn
+ (bibtex-beginning-of-entry)
+ (error "Entry with key `%s' already exists" entry-name))))))
+ (if dup
+ (progn
+ (bibtex-beginning-of-entry)
+ nil)
+ (goto-char right)
+ (setq actual-key
+ (if (looking-at bibtex-entry-head)
+ (buffer-substring-no-properties
+ (match-beginning bibtex-key-in-entry)
+ (match-end bibtex-key-in-entry))))
+ (if (or
+ (not actual-key)
+ (string-lessp actual-key entry-name))
+ ;; buffer contains no valid entries or
+ ;; greater than last entry --> append
+ (progn
+ (bibtex-end-of-entry)
+ (if (not (bobp))
+ (newline (forward-line 2)))
+ (beginning-of-line))
+ (goto-char right))
+ t)))
+
+(defun bibtex-validate (&optional test-thoroughly)
+ "Validate if buffer or region is syntactically correct.
+Only known entry types are checked, so you can put comments
+outside of entries.
+With optional argument TEST-THOROUGHLY non-nil it checks for absence of
+required fields and questionable month fields as well.
+If mark is active, it validates current region, if not whole buffer.
+Returns t if test was successful, nil otherwise."
+ (interactive "P")
+ (let* (error-list
+ syntax-error
+ (case-fold-search t)
+ (valid-bibtex-entry
+ (concat
+ "@[ \t]*\\(\\(string\\)\\|"
+ (mapconcat
+ (lambda (type)
+ (concat "\\(" (car type) "\\)"))
+ bibtex-entry-field-alist
+ "\\|")
+ "\\)"))
+ (pnt (point))
+ (start-point
+ (if (bibtex-mark-active)
+ (region-beginning)
+ (bibtex-beginning-of-first-entry)))
+ (end-point
+ (if (bibtex-mark-active)
+ (region-end)
+ (point-max))))
+ (save-restriction
+ (narrow-to-region start-point end-point)
+ ;; looking if entries fit syntactical structure
+ (goto-char start-point)
+ (bibtex-progress-message "Checking syntactical structure")
+ (while (re-search-forward "^[ \t]*@" nil t)
+ (bibtex-progress-message)
+ (forward-char -1)
+ (let ((p (point))
+ (must-match
+ (looking-at valid-bibtex-entry)))
+ (if (not must-match)
+ (forward-char)
+ (let (bibtex-sort-ignore-string-entries)
+ (bibtex-skip-to-valid-entry))
+ (if (equal (point) p)
+ (forward-char)
+ (goto-char p)
+ (setq
+ error-list
+ (cons (list
+ (bibtex-current-line)
+ "Syntax error (check esp. commas, braces, and quotes)")
+ error-list))
+ (forward-char)))))
+ (bibtex-progress-message 'done)
+ (if error-list
+ (setq syntax-error t)
+ ;; looking for correct sort order and duplicates (only if
+ ;; there were no syntax errors)
+ (if bibtex-maintain-sorted-entries
+ (let (previous)
+ (goto-char start-point)
+ (bibtex-progress-message "Checking correct sort order")
+ (bibtex-map-entries
+ (lambda (current)
+ (bibtex-progress-message)
+ (cond ((or (not previous)
+ (string< previous current))
+ (setq previous current))
+ ((string-equal previous current)
+ (setq
+ error-list
+ (cons (list (bibtex-current-line)
+ "Duplicate key with previous")
+ error-list)))
+ (t
+ (setq previous current
+ error-list
+ (cons (list (bibtex-current-line)
+ "Entries out of order")
+ error-list))))))
+ (bibtex-progress-message 'done)))
+ (if test-thoroughly
+ (progn
+ (goto-char start-point)
+ (bibtex-progress-message
+ "Checking required fields and month fields")
+ (let ((bibtex-sort-ignore-string-entries t)
+ (questionable-month
+ (concat
+ "[{\"]\\("
+ (mapconcat
+ (lambda (mon)
+ (concat "\\(" (car mon) "\\)"))
+ bibtex-predefined-month-strings
+ "\\|")
+ "\\)[}\"]")))
+ (bibtex-map-entries
+ (lambda (current)
+ (bibtex-progress-message)
+ (let* ((beg (bibtex-beginning-of-entry))
+ (end (bibtex-end-of-entry))
+ (entry-list
+ (progn
+ (goto-char beg)
+ (bibtex-search-entry nil end)
+ (assoc-ignore-case
+ (buffer-substring-no-properties
+ (1+ (match-beginning bibtex-type-in-head))
+ (match-end bibtex-type-in-head))
+ bibtex-entry-field-alist)))
+ (req (copy-sequence (elt (elt entry-list 1) 0)))
+ (creq (copy-sequence (elt (elt entry-list 2) 0)))
+ crossref-there)
+ (goto-char beg)
+ (let ((bounds (bibtex-search-forward-field bibtex-field-name end)))
+ (while bounds
+ (let ((field-name
+ (buffer-substring-no-properties
+ (bibtex-start-of-name-in-field bounds)
+ (bibtex-end-of-name-in-field bounds))))
+ (if (and (equal (downcase field-name) "month")
+ (string-match
+ questionable-month
+ (buffer-substring-no-properties
+ (bibtex-start-of-text-in-field bounds)
+ (bibtex-end-of-text-in-field bounds))))
+ (setq
+ error-list
+ (cons
+ (list
+ (bibtex-current-line)
+ "Questionable month field (delimited string)")
+ error-list)))
+ (setq
+ req
+ (delete (assoc-ignore-case field-name req) req)
+ creq
+ (delete (assoc-ignore-case field-name creq) creq))
+ (if (equal (downcase field-name) "crossref")
+ (setq crossref-there t)))
+ (goto-char (bibtex-end-of-field bounds))
+ (setq bounds (bibtex-search-forward-field bibtex-field-name end))))
+ (if crossref-there
+ (setq req creq))
+ (if (or (> (length req) 1)
+ (and (= (length req) 1)
+ (not (elt (car req) 3))))
+ ;; two (or more) fields missed or one field
+ ;; missed and this isn't flagged alternative
+ ;; (notice that this fails if there are more
+ ;; than two alternatives in a BibTeX entry,
+ ;; which isn't the case momentarily)
+ (setq
+ error-list
+ (cons
+ (list (save-excursion
+ (bibtex-beginning-of-entry)
+ (bibtex-current-line))
+ (concat
+ "Required field \""
+ (car (car req))
+ "\" missing"))
+ error-list)))))))
+ (bibtex-progress-message 'done)))))
+ (goto-char pnt)
+ (if error-list
+ (let ((bufnam (buffer-name))
+ (dir default-directory))
+ (setq error-list
+ (sort error-list
+ (lambda (a b)
+ (< (car a) (car b)))))
+ (let ((pop-up-windows t))
+ (pop-to-buffer nil t))
+ (switch-to-buffer
+ (get-buffer-create "*BibTeX validation errors*") t)
+ ;; don't use switch-to-buffer-other-window, since this
+ ;; doesn't allow the second parameter NORECORD
+ (setq default-directory dir)
+ (toggle-read-only -1)
+ (compilation-mode)
+ (delete-region (point-min) (point-max))
+ (goto-char (point-min))
+ (insert
+ "BibTeX mode command `bibtex-validate'\n"
+ (if syntax-error
+ "Maybe undetected errors due to syntax errors. Correct and validate again."
+ "")
+ "\n")
+ (while error-list
+ (insert
+ bufnam ":" (number-to-string (elt (car error-list) 0))
+ ": " (elt (car error-list) 1) "\n")
+ (setq error-list (cdr error-list)))
+ (compilation-parse-errors nil nil)
+ (setq compilation-old-error-list compilation-error-list)
+ ;; this is necessary to avoid reparsing of buffer if you
+ ;; switch to compilation buffer and enter
+ ;; `compile-goto-error'
+ (set-buffer-modified-p nil)
+ (toggle-read-only 1)
+ (goto-char (point-min))
+ (other-window -1)
+ ;; return nil
+ nil)
+ (if (bibtex-mark-active)
+ (message "Region is syntactically correct")
+ (message "Buffer is syntactically correct"))
+ t)))
+
+(defun bibtex-next-field (arg)
+ "Finds end of text of next BibTeX field; with ARG, to its beginning."
+ (interactive "P")
+ (bibtex-inside-field)
+ (let ((start (point)))
+ (condition-case ()
+ (let ((bounds (bibtex-enclosing-field)))
+ (goto-char (bibtex-end-of-field bounds))
+ (forward-char 2))
+ (error
+ (goto-char start)
+ (end-of-line)
+ (forward-char))))
+ (bibtex-find-text arg t))
+
+(defun bibtex-find-text (arg &optional as-if-interactive silent)
+ "Go to end of text of current field; with ARG, go to beginning."
+ (interactive "P")
+ (bibtex-inside-field)
+ (let ((bounds (bibtex-enclosing-field (or (interactive-p) as-if-interactive))))
+ (if bounds
+ (progn
+ (if arg
+ (progn
+ (goto-char (bibtex-start-of-text-in-field bounds))
+ (if (looking-at "[{\"]")
+ (forward-char)))
+ (goto-char (bibtex-end-of-text-in-field bounds))
+ (if (or
+ (= (preceding-char) ?})
+ (= (preceding-char) ?\"))
+ (forward-char -1)))
+ (if bibtex-help-message
+ (bibtex-print-help-message)))
+ (beginning-of-line)
+ (cond
+ ((bibtex-parse-string)
+ (let ((bounds (bibtex-parse-string)))
+ (goto-char
+ (if arg
+ (bibtex-start-of-text-in-string bounds)
+ (bibtex-end-of-text-in-string bounds)))))
+ ((looking-at bibtex-entry-maybe-empty-head)
+ (goto-char
+ (if arg
+ (match-beginning bibtex-key-in-head)
+ (match-end 0))))
+ (t
+ (if (not silent)
+ (error "Not on BibTeX field")))))))
+
+(defun bibtex-remove-OPT-or-ALT ()
+ "Removes the string starting optional/alternative fields.
+Aligns text and goes thereafter to end of text."
+ (interactive)
+ (bibtex-inside-field)
+ (let* ((case-fold-search t)
+ (bounds (bibtex-enclosing-field)))
+ (save-excursion
+ (goto-char (bibtex-start-of-name-in-field bounds))
+ (if (looking-at "OPT\\|ALT")
+ (progn
+ (delete-char (length "OPT"))
+ ;; make field non-OPT
+ (search-forward "=")
+ (forward-char -1)
+ (delete-horizontal-space)
+ (if bibtex-align-at-equal-sign
+ (indent-to-column (- bibtex-text-indentation 2))
+ (insert " "))
+ (search-forward "=")
+ (delete-horizontal-space)
+ (if bibtex-align-at-equal-sign
+ (insert " ")
+ (indent-to-column bibtex-text-indentation)))))
+ (bibtex-inside-field)))
+
+(defun bibtex-remove-delimiters ()
+ "Removes \"\" or {} around string."
+ (interactive)
+ (save-excursion
+ (bibtex-inside-field)
+ (let* ((case-fold-search t)
+ (bounds (bibtex-enclosing-field))
+ (stop (copy-marker (bibtex-end-of-text-in-field bounds))))
+ (goto-char (bibtex-start-of-text-in-field bounds))
+ (let* ((boundaries (bibtex-search-forward-field-string stop)))
+ (while boundaries
+ (let ((text-end (copy-marker (cdr boundaries))))
+ (goto-char (car boundaries))
+ (delete-char 1)
+ (goto-char text-end)
+ (delete-backward-char 1)
+ (setq boundaries (bibtex-search-forward-field-string stop))))))))
+
+(defun bibtex-kill-field (&optional copy-only)
+ "Kills the entire enclosing BibTeX field.
+With prefix arg COPY-ONLY, copy the current field to `bibtex-field-kill-ring,'
+but do not actually kill it."
+ (interactive "P")
+ (let* ((pnt (point))
+ (case-fold-search t))
+ (bibtex-inside-field)
+ (let* ((bounds (bibtex-enclosing-field))
+ (the-end (bibtex-end-of-field bounds))
+ (the-beginning (bibtex-start-of-field bounds)))
+ (goto-char the-end)
+ (skip-chars-forward " \t\n,")
+ (setq
+ bibtex-field-kill-ring
+ (cons
+ (list
+ 'field
+ (buffer-substring-no-properties
+ (bibtex-start-of-name-in-field bounds)
+ (bibtex-end-of-name-in-field bounds))
+ (buffer-substring-no-properties
+ (bibtex-start-of-text-in-field bounds)
+ (bibtex-end-of-text-in-field bounds)))
+ bibtex-field-kill-ring))
+ (if (> (length bibtex-field-kill-ring) bibtex-field-kill-ring-max)
+ (setcdr
+ (nthcdr (1- bibtex-field-kill-ring-max) bibtex-field-kill-ring)
+ nil))
+ (setq bibtex-field-kill-ring-yank-pointer bibtex-field-kill-ring)
+ (if copy-only
+ (goto-char pnt)
+ (delete-region the-beginning the-end)
+ (let (bibtex-help-message)
+ (bibtex-find-text nil t t)))))
+ (setq bibtex-last-kill-command 'field))
+
+(defun bibtex-copy-field-as-kill ()
+ (interactive)
+ (bibtex-kill-field t))
+
+(defun bibtex-kill-entry (&optional copy-only)
+ "Kill the entire enclosing BibTeX entry.
+With prefix arg COPY-ONLY the current entry to
+`bibtex-entry-kill-ring', but do not actually kill it."
+ (interactive "P")
+ (let* ((pnt (point))
+ (case-fold-search t)
+ (beg (bibtex-beginning-of-entry))
+ (end
+ (progn
+ (bibtex-end-of-entry)
+ (if (re-search-forward
+ bibtex-entry-maybe-empty-head nil 'move)
+ (goto-char (match-beginning 0)))
+ (point))))
+ (setq
+ bibtex-entry-kill-ring
+ (cons
+ (list 'entry (buffer-substring-no-properties beg end))
+ bibtex-entry-kill-ring))
+ (if (> (length bibtex-entry-kill-ring) bibtex-entry-kill-ring-max)
+ (setcdr
+ (nthcdr (1- bibtex-entry-kill-ring-max) bibtex-entry-kill-ring)
+ nil))
+ (setq bibtex-entry-kill-ring-yank-pointer bibtex-entry-kill-ring)
+ (if copy-only
+ (goto-char pnt)
+ (delete-region beg end)))
+ (setq bibtex-last-kill-command 'entry))
+
+(defun bibtex-copy-entry-as-kill ()
+ (interactive)
+ (bibtex-kill-entry t))
+
+(defun bibtex-yank (&optional n)
+ "Reinsert the last BibTeX item.
+More precisely, reinsert the field or entry killed or yanked most recently.
+With argument N, reinsert the Nth most recently killed BibTeX item.
+See also the command \\[bibtex-yank-pop]]."
+ (interactive "*p")
+ (bibtex-insert-current-kill (1- n))
+ (setq this-command 'bibtex-yank))
+
+(defun bibtex-yank-pop (n)
+ "Replace just-yanked killed BibTeX item with a different.
+This command is allowed only immediately after a `bibtex-yank' or a
+`bibtex-yank-pop'.
+At such a time, the region contains a reinserted previously killed
+BibTeX item. `bibtex-yank-pop' deletes that item and inserts in its
+place a different killed BibTeX item.
+
+With no argument, the previous kill is inserted.
+With argument N, insert the Nth previous kill.
+If N is negative, this is a more recent kill.
+
+The sequence of kills wraps around, so that after the oldest one
+comes the newest one."
+ (interactive "*p")
+ (if (not (eq last-command 'bibtex-yank))
+ (error "Previous command was not a BibTeX yank"))
+ (setq this-command 'bibtex-yank)
+ (let ((inhibit-read-only t))
+ (delete-region (point) (mark t))
+ (bibtex-insert-current-kill n)))
+
+(defun bibtex-empty-field ()
+ "Delete the text part of the current field, replace with empty text."
+ (interactive)
+ (bibtex-inside-field)
+ (let ((bounds (bibtex-enclosing-field)))
+ (goto-char (bibtex-start-of-text-in-field bounds))
+ (delete-region (point) (bibtex-end-of-text-in-field bounds))
+ (insert (concat (bibtex-field-left-delimiter)
+ (bibtex-field-right-delimiter)) )
+ (bibtex-find-text t)))
+
+(defun bibtex-pop-previous (arg)
+ "Replace text of current field with the similar field in previous entry.
+With arg, goes up ARG entries. Repeated, goes up so many times. May be
+intermixed with \\[bibtex-pop-next] (bibtex-pop-next)."
+ (interactive "p")
+ (bibtex-pop arg 'previous))
+
+(defun bibtex-pop-next (arg)
+ "Replace text of current field with the text of similar field in next entry.
+With arg, goes down ARG entries. Repeated, goes down so many times. May be
+intermixed with \\[bibtex-pop-previous] (bibtex-pop-previous)."
+ (interactive "p")
+ (bibtex-pop arg 'next))
+
+(defun bibtex-clean-entry (&optional new-reference-key called-by-reformat)
+ "Finish editing the current BibTeX entry and clean it up.
+Checks that no required fields are empty and formats entry dependent
+on the value of bibtex-entry-format.
+If the reference key of the entry is empty or a prefix argument is given,
+calculate a new reference key (note: this only will work if fields in entry
+begin on separate lines prior to calling bibtex-clean-entry or if 'realign is
+contained in bibtex-entry-format).
+Don't call this on `string' or `preamble' entries.
+At end of the cleaning process, the functions in
+bibtex-clean-entry-hook are called with region narrowed to entry."
+ (interactive "P")
+ (bibtex-format-entry)
+ (let* ((case-fold-search t)
+ (eob (bibtex-end-of-entry))
+ (key (progn
+ (bibtex-beginning-of-entry)
+ (if (re-search-forward
+ bibtex-entry-head eob t)
+ (buffer-substring-no-properties
+ (match-beginning bibtex-key-in-head)
+ (match-end bibtex-key-in-head))))))
+ (if (or
+ new-reference-key
+ (not key))
+ (progn
+ (let ((autokey
+ (if bibtex-autokey-edit-before-use
+ (read-from-minibuffer
+ "Key to use: " (bibtex-generate-autokey) nil nil
+ 'bibtex-key-history)
+ (bibtex-generate-autokey))))
+ (bibtex-beginning-of-entry)
+ (re-search-forward bibtex-entry-maybe-empty-head)
+ (if (match-beginning bibtex-key-in-head)
+ (delete-region (match-beginning bibtex-key-in-head)
+ (match-end bibtex-key-in-head)))
+ (insert autokey)
+ (let* ((start (bibtex-beginning-of-entry))
+ (end (progn
+ (bibtex-end-of-entry)
+ (if (re-search-forward
+ bibtex-entry-maybe-empty-head nil 'move)
+ (goto-char (match-beginning 0)))
+ (point)))
+ (entry (buffer-substring start end)))
+ (delete-region start end)
+ (let ((success
+ (or
+ called-by-reformat
+ (not bibtex-maintain-sorted-entries)
+ (bibtex-find-entry-location autokey t))))
+ (insert entry)
+ (forward-char -1)
+ (bibtex-beginning-of-entry)
+ (re-search-forward bibtex-entry-head)
+ (if (not success)
+ (error
+ "New inserted entry yields duplicate key"))))))))
+ (if (not called-by-reformat)
+ (save-excursion
+ (save-restriction
+ (narrow-to-region
+ (bibtex-beginning-of-entry) (bibtex-end-of-entry))
+ (bibtex-parse-keys t nil)
+ (run-hooks 'bibtex-clean-entry-hook)))))
+
+(defun bibtex-fill-entry ()
+ "Fill current entry.
+Realigns entry, so that every field starts on a separate line. Field
+names appear in column `bibtex-field-indentation', field text starts in
+column `bibtex-text-indentation' and continuation lines start here, too.
+If `bibtex-align-at-equal-sign' is non-nil, align equal signs also."
+ (interactive "*")
+ (let ((pnt (copy-marker (point)))
+ (end (copy-marker (bibtex-end-of-entry))))
+ (bibtex-beginning-of-entry)
+ (bibtex-delete-whitespace)
+ (indent-to-column bibtex-entry-offset)
+ (let ((bounds (bibtex-search-forward-field bibtex-field-name end)))
+ (while bounds
+ (let* ((begin-field (copy-marker (bibtex-start-of-field bounds)))
+ (end-field (copy-marker (bibtex-end-of-field bounds)))
+ (begin-name (copy-marker (bibtex-start-of-name-in-field bounds)))
+ (end-name (copy-marker (bibtex-end-of-name-in-field bounds))))
+ (goto-char begin-field)
+ (forward-char)
+ (bibtex-delete-whitespace)
+ (open-line 1)
+ (forward-char)
+ (indent-to-column
+ (+ bibtex-entry-offset bibtex-field-indentation))
+ (re-search-forward "[ \t\n]*=" end)
+ (replace-match "=")
+ (forward-char -1)
+ (if bibtex-align-at-equal-sign
+ (indent-to-column
+ (+ bibtex-entry-offset (- bibtex-text-indentation 2)))
+ (insert " "))
+ (forward-char)
+ (bibtex-delete-whitespace)
+ (if bibtex-align-at-equal-sign
+ (insert " ")
+ (indent-to-column bibtex-text-indentation))
+ (while (re-search-forward "[ \t\n]+" end-field 'move)
+ (replace-match " "))
+ (bibtex-do-auto-fill)
+ (goto-char end-field))
+ (setq bounds (bibtex-search-forward-field bibtex-field-name end))))
+ (if (looking-at ",")
+ (forward-char))
+ (bibtex-delete-whitespace)
+ (open-line 1)
+ (forward-char)
+ (indent-to-column bibtex-entry-offset)
+ (goto-char pnt)))
+
+(defun bibtex-reformat (&optional additional-options called-by-convert-alien)
+ "Reformat all BibTeX entries in buffer or region.
+With prefix argument, read options for reformatting from minibuffer.
+With \\[universal-argument] \\[universal-argument] prefix argument, reuse previous answers (if any) again.
+If mark is active it reformats entries in region, if not in whole buffer."
+ (interactive "*P")
+ (let* ((pnt (point))
+ (use-previous-options
+ (and (equal (prefix-numeric-value additional-options) 16)
+ (or bibtex-reformat-previous-options
+ bibtex-reformat-previous-reference-keys)))
+ (bibtex-entry-format
+ (if additional-options
+ (if use-previous-options
+ bibtex-reformat-previous-options
+ (setq
+ bibtex-reformat-previous-options
+ (delq
+ nil
+ (list
+ (if (or
+ called-by-convert-alien
+ (y-or-n-p
+ "Realign entries (recommended for files not created by BibTeX mode)? "))
+ 'realign)
+ (if (y-or-n-p
+ "Remove empty optional and alternative fields? ")
+ 'opts-or-alts)
+ (if (y-or-n-p
+ "Remove delimiters around pure numerical fields? ")
+ 'numerical-fields)
+ (if (y-or-n-p (concat
+ (if bibtex-comma-after-last-field
+ "Insert"
+ "Remove")
+ " comma at end of entry? "))
+ 'last-comma)
+ (if (y-or-n-p
+ "Replace double page dashes by single ones? ")
+ 'page-dashes)
+ (if (y-or-n-p
+ "Force delimiters? ")
+ 'delimiters)
+ (if (y-or-n-p
+ "Unify case of entry types and field names? ")
+ 'unify-case)))))
+ '(realign)))
+ (reformat-reference-keys
+ (if additional-options
+ (if use-previous-options
+ bibtex-reformat-previous-reference-keys
+ (setq
+ bibtex-reformat-previous-reference-keys
+ (y-or-n-p "Generate new reference keys automatically? ")))))
+ bibtex-autokey-edit-before-use
+ (bibtex-sort-ignore-string-entries t)
+ (start-point
+ (if (bibtex-mark-active)
+ (region-beginning)
+ (progn
+ (bibtex-beginning-of-first-entry)
+ (bibtex-skip-to-valid-entry)
+ (point))))
+ (end-point
+ (if (bibtex-mark-active)
+ (region-end)
+ (point-max)))
+ (valid-bibtex-entry
+ (concat
+ "[ \t\n]+\\(@[ \t]*\\("
+ (mapconcat
+ (lambda (type)
+ (concat "\\(" (car type) "\\)"))
+ bibtex-entry-field-alist
+ "\\|")
+ "\\)\\)")))
+ (save-restriction
+ (narrow-to-region start-point end-point)
+ (if (memq 'realign bibtex-entry-format)
+ (progn
+ (goto-char (point-min))
+ (while (re-search-forward valid-bibtex-entry nil t)
+ (replace-match "\n\\1"))))
+ (goto-char start-point)
+ (bibtex-progress-message "Formatting" 1)
+ (bibtex-map-entries
+ (lambda (current)
+ (bibtex-progress-message)
+ (bibtex-clean-entry reformat-reference-keys reformat-reference-keys)
+ (if (memq 'realign bibtex-entry-format)
+ (progn
+ (bibtex-end-of-entry)
+ (bibtex-delete-whitespace)
+ (open-line 2)))))
+ (bibtex-progress-message 'done))
+ (if (and
+ reformat-reference-keys
+ bibtex-maintain-sorted-entries
+ (not called-by-convert-alien))
+ (progn
+ (bibtex-sort-buffer)
+ (setq bibtex-reference-keys nil)
+ (bibtex-parse-keys nil t t)))
+ (goto-char pnt)))
+
+(defun bibtex-convert-alien (&optional do-additional-reformatting)
+ "Converts an alien BibTeX buffer to be fully usable by BibTeX mode.
+If a file doesn't confirm with some standards used by BibTeX mode,
+some of the high-level features of BibTeX mode won't be available.
+This function tries to convert current buffer to confirm with these standards.
+With prefix argument DO-ADDITIONAL-REFORMATTING
+non-nil, read options for reformatting entries from minibuffer."
+ (interactive "*P")
+ (message "Starting to validate buffer...")
+ (sit-for 1 nil t)
+ (goto-char (point-min))
+ (while (re-search-forward "[ \t\n]+@" nil t)
+ (replace-match "\n@"))
+ (message
+ "If errors occur, correct them and call `bibtex-convert-alien' again")
+ (sit-for 5 nil t)
+ (if (let ((bibtex-mark-active)
+ bibtex-maintain-sorted-entries)
+ (bibtex-validate))
+ (progn
+ (message "Starting to reformat entries...")
+ (sit-for 2 nil t)
+ (bibtex-reformat do-additional-reformatting t)
+ (if bibtex-maintain-sorted-entries
+ (progn
+ (message "Starting to sort buffer...")
+ (bibtex-sort-buffer)))
+ (goto-char (point-max))
+ (message "Buffer is now parsable. Please save it."))))
+
+(defun bibtex-complete-string ()
+ "Complete word fragment before point to longest prefix of a defined string.
+If point is not after the part of a word, all strings are listed.
+Remove surrounding delimiters if complete string could be expanded."
+ (interactive "*")
+ (bibtex-complete bibtex-strings t))
+
+(defun bibtex-complete-key ()
+ "Complete word fragment before point to longest prefix of a defined key.
+If point is not after the part of a word, all keys are listed. This
+function is most useful in completing crossref entries."
+ (interactive "*")
+ (if (not bibtex-reference-keys)
+ (bibtex-parse-keys nil t))
+ (bibtex-complete bibtex-reference-keys))
+
+(defun bibtex-Article ()
+ "Insert a new BibTeX @Article entry; see also `bibtex-entry'."
+ (interactive)
+ (bibtex-entry "Article"))
+
+(defun bibtex-Book ()
+ "Insert a new BibTeX @Book entry; see also `bibtex-entry'."
+ (interactive)
+ (bibtex-entry "Book"))
+
+(defun bibtex-Booklet ()
+ "Insert a new BibTeX @Booklet entry; see also `bibtex-entry'."
+ (interactive)
+ (bibtex-entry "Booklet"))
+
+(defun bibtex-InBook ()
+ "Insert a new BibTeX @InBook entry; see also `bibtex-entry'."
+ (interactive)
+ (bibtex-entry "InBook"))
+
+(defun bibtex-InCollection ()
+ "Insert a new BibTeX @InCollection entry; see also `bibtex-entry'."
+ (interactive)
+ (bibtex-entry "InCollection"))
+
+(defun bibtex-InProceedings ()
+ "Insert a new BibTeX @InProceedings entry; see also `bibtex-entry'."
+ (interactive)
+ (bibtex-entry "InProceedings"))
+
+(defun bibtex-Manual ()
+ "Insert a new BibTeX @Manual entry; see also `bibtex-entry'."
+ (interactive)
+ (bibtex-entry "Manual"))
+
+(defun bibtex-MastersThesis ()
+ "Insert a new BibTeX @MastersThesis entry; see also `bibtex-entry'."
+ (interactive)
+ (bibtex-entry "MastersThesis"))
+
+(defun bibtex-Misc ()
+ "Insert a new BibTeX @Misc entry; see also `bibtex-entry'."
+ (interactive)
+ (bibtex-entry "Misc"))
+
+(defun bibtex-PhdThesis ()
+ "Insert a new BibTeX @PhdThesis entry; see also `bibtex-entry'."
+ (interactive)
+ (bibtex-entry "PhdThesis"))
+
+(defun bibtex-Proceedings ()
+ "Insert a new BibTeX @Proceedings entry; see also `bibtex-entry'."
+ (interactive)
+ (bibtex-entry "Proceedings"))
+
+(defun bibtex-TechReport ()
+ "Insert a new BibTeX @TechReport entry; see also `bibtex-entry'."
+ (interactive)
+ (bibtex-entry "TechReport"))
+
+(defun bibtex-Unpublished ()
+ "Insert a new BibTeX @Unpublished entry; see also `bibtex-entry'."
+ (interactive)
+ (bibtex-entry "Unpublished"))
+
+(defun bibtex-String ()
+ "Insert a new BibTeX @String entry."
+ (interactive)
+ (if (not bibtex-reference-keys)
+ (bibtex-parse-keys nil t))
+ (let ((key
+ (if (and
+ bibtex-maintain-sorted-entries
+ (not bibtex-sort-ignore-string-entries))
+ (completing-read
+ "String key: " bibtex-reference-keys nil nil nil 'bibtex-key-history))))
+ (if (and
+ bibtex-maintain-sorted-entries
+ (not bibtex-sort-ignore-string-entries))
+ (bibtex-find-entry-location key)
+ (bibtex-move-outside-of-entry))
+ (indent-to-column bibtex-entry-offset)
+ (insert
+ (concat
+ "@String"
+ (bibtex-entry-left-delimiter)
+ (if (and
+ bibtex-maintain-sorted-entries
+ (not bibtex-sort-ignore-string-entries))
+ key)
+ " = "
+ (bibtex-field-left-delimiter)
+ (bibtex-field-right-delimiter)
+ (bibtex-entry-right-delimiter)
+ "\n"))
+ (forward-line -1)
+ (forward-char
+ (if (and
+ bibtex-maintain-sorted-entries
+ (not bibtex-sort-ignore-string-entries))
+ (+ (length "@String{") (length key) (length " = {"))
+ (length "@String{")))))
+
+(defun bibtex-Preamble ()
+ "Insert a new BibTeX @Preamble entry."
+ (interactive)
+ (bibtex-move-outside-of-entry)
+ (indent-to-column bibtex-entry-offset)
+ (insert
+ "@Preamble"
+ (bibtex-entry-left-delimiter)
+ (bibtex-entry-right-delimiter)
+ "\n")
+ (forward-line -1)
+ (forward-char 10))
+
+\f
+;; Make BibTeX a Feature
+
+(provide 'bibtex)
+
+;;; bibtex.el ends here
--- /dev/null
+;;; cperl-mode.el --- Perl code editing commands for Emacs\r
+\r
+;; Copyright (C) 1985, 86, 87, 91, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 2003\r
+;; Free Software Foundation, Inc.\r
+\r
+;; Author: Ilya Zakharevich and Bob Olson\r
+;; Maintainer: Ilya Zakharevich <cperl@ilyaz.org>\r
+;; Keywords: languages, Perl\r
+\r
+;; This file is part of GNU Emacs.\r
+\r
+;;; This code started from the following message of long time ago\r
+;;; (IZ), but Bob does not maintain this mode any more:\r
+\r
+;;; From: olson@mcs.anl.gov (Bob Olson)\r
+;;; Newsgroups: comp.lang.perl\r
+;;; Subject: cperl-mode: Another perl mode for Gnuemacs\r
+;;; Date: 14 Aug 91 15:20:01 GMT\r
+\r
+;; Copyright (C) Ilya Zakharevich and Bob Olson\r
+\r
+;; This file may be distributed\r
+;; either under the same terms as GNU Emacs, or under the same terms\r
+;; as Perl. You should have received a copy of Perl Artistic license\r
+;; along with the Perl distribution.\r
+\r
+;; GNU Emacs is free software; you can redistribute it and/or modify\r
+;; it under the terms of the GNU General Public License as published by\r
+;; the Free Software Foundation; either version 2, or (at your option)\r
+;; any later version.\r
+\r
+;; GNU Emacs is distributed in the hope that it will be useful,\r
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of\r
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
+;; GNU General Public License for more details.\r
+\r
+;; You should have received a copy of the GNU General Public License\r
+;; along with GNU Emacs; see the file COPYING. If not, write to the\r
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,\r
+;; Boston, MA 02111-1307, USA.\r
+\r
+;;; Corrections made by Ilya Zakharevich cperl@ilyaz.org\r
+;;; XEmacs changes by Peter Arius arius@informatik.uni-erlangen.de\r
+\r
+;;; Commentary:\r
+\r
+;; $Id: cperl-mode.el,v 5.0 2003/02/17 01:33:20 vera Exp vera $\r
+\r
+;;; If your Emacs does not default to `cperl-mode' on Perl files:\r
+;;; To use this mode put the following into\r
+;;; your .emacs file:\r
+\r
+;; (autoload 'perl-mode "cperl-mode" "alternate mode for editing Perl programs" t)\r
+\r
+;; You can either fine-tune the bells and whistles of this mode or\r
+;; bulk enable them by putting\r
+\r
+;; (setq cperl-hairy t)\r
+\r
+;; in your .emacs file. (Emacs rulers do not consider it politically\r
+;; correct to make whistles enabled by default.)\r
+\r
+;; DO NOT FORGET to read micro-docs (available from `Perl' menu) <<<<<<\r
+;; or as help on variables `cperl-tips', `cperl-problems', <<<<<<\r
+;; `cperl-non-problems', `cperl-praise', `cperl-speed'. <<<<<<\r
+\r
+;; Additional useful commands to put into your .emacs file (before\r
+;; RMS Emacs 20.3):\r
+\r
+;; (setq auto-mode-alist\r
+;; (append '(("\\.\\([pP][Llm]\\|al\\)$" . perl-mode)) auto-mode-alist ))\r
+;; (setq interpreter-mode-alist (append interpreter-mode-alist\r
+;; '(("miniperl" . perl-mode))))\r
+\r
+;; The mode information (on C-h m) provides some customization help.\r
+;; If you use font-lock feature of this mode, it is advisable to use\r
+;; either lazy-lock-mode or fast-lock-mode. I prefer lazy-lock.\r
+\r
+;; Faces used now: three faces for first-class and second-class keywords\r
+;; and control flow words, one for each: comments, string, labels,\r
+;; functions definitions and packages, arrays, hashes, and variable\r
+;; definitions. If you do not see all these faces, your font-lock does\r
+;; not define them, so you need to define them manually.\r
+;; Maybe you have an obsolete font-lock from 19.28 or earlier. Upgrade.\r
+\r
+;; If you have a grayscale monitor, and do not have the variable\r
+;; font-lock-display-type bound to 'grayscale, insert\r
+\r
+;; (setq font-lock-display-type 'grayscale)\r
+\r
+;; into your .emacs file (this is relevant before RMS Emacs 20).\r
+\r
+;; This mode supports font-lock, imenu and mode-compile. In the\r
+;; hairy version font-lock is on, but you should activate imenu\r
+;; yourself (note that mode-compile is not standard yet). Well, you\r
+;; can use imenu from keyboard anyway (M-x imenu), but it is better\r
+;; to bind it like that:\r
+\r
+;; (define-key global-map [M-S-down-mouse-3] 'imenu)\r
+\r
+;;; Font lock bugs as of v4.32:\r
+\r
+;; The following kinds of Perl code erroneously start strings:\r
+;; \$` \$' \$"\r
+;; $opt::s $opt_s $opt{s} (s => ...) /\s+.../\r
+;; likewise with m, tr, y, q, qX instead of s\r
+\r
+;;; In fact the version of font-lock that this version supports can be\r
+;;; much newer than the version you actually have. This means that a\r
+;;; lot of faces can be set up, but are not visible on your screen\r
+;;; since the coloring rules for this faces are not defined.\r
+\r
+;;; Updates: ========================================\r
+\r
+;;; Made less hairy by default: parentheses not electric,\r
+;;; linefeed not magic. Bug with abbrev-mode corrected.\r
+\r
+;;;; After 1.4:\r
+;;; Better indentation:\r
+;;; subs inside braces should work now,\r
+;;; Toplevel braces obey customization.\r
+;;; indent-for-comment knows about bad cases, cperl-indent-for-comment\r
+;;; moves cursor to a correct place.\r
+;;; cperl-indent-exp written from the scratch! Slow... (quadratic!) :-(\r
+;;; (50 secs on DB::DB (sub of 430 lines), 486/66)\r
+;;; Minor documentation fixes.\r
+;;; Imenu understands packages as prefixes (including nested).\r
+;;; Hairy options can be switched off one-by-one by setting to null.\r
+;;; Names of functions and variables changed to conform to `cperl-' style.\r
+\r
+;;;; After 1.5:\r
+;;; Some bugs with indentation of labels (and embedded subs) corrected.\r
+;;; `cperl-indent-region' done (slow :-()).\r
+;;; `cperl-fill-paragraph' done.\r
+;;; Better package support for `imenu'.\r
+;;; Progress indicator for indentation (with `imenu' loaded).\r
+;;; `Cperl-set' was busted, now setting the individual hairy option\r
+;;; should be better.\r
+\r
+;;;; After 1.6:\r
+;;; `cperl-set-style' done.\r
+;;; `cperl-check-syntax' done.\r
+;;; Menu done.\r
+;;; New config variables `cperl-close-paren-offset' and `cperl-comment-column'.\r
+;;; Bugs with `cperl-auto-newline' corrected.\r
+;;; `cperl-electric-lbrace' can work with `cperl-auto-newline' in situation\r
+;;; like $hash{.\r
+\r
+;;;; 1.7 XEmacs (arius@informatik.uni-erlangen.de):\r
+;;; - use `next-command-event', if `next-command-events' does not exist\r
+;;; - use `find-face' as def. of `is-face'\r
+;;; - corrected def. of `x-color-defined-p'\r
+;;; - added const defs for font-lock-comment-face,\r
+;;; font-lock-keyword-face and font-lock-function-name-face\r
+;;; - added def. of font-lock-variable-name-face\r
+;;; - added (require 'easymenu) inside an `eval-when-compile'\r
+;;; - replaced 4-argument `substitute-key-definition' with ordinary\r
+;;; `define-key's\r
+;;; - replaced `mark-active' in menu definition by `cperl-use-region-p'.\r
+;;; Todo (at least):\r
+;;; - use emacs-vers.el (http://www.cs.utah.edu/~eeide/emacs/emacs-vers.el.gz)\r
+;;; for portable code?\r
+;;; - should `cperl-mode' do a\r
+;;; (if (featurep 'easymenu) (easy-menu-add cperl-menu))\r
+;;; or should this be left to the user's `cperl-mode-hook'?\r
+\r
+;;; Some bugs introduced by the above fix corrected (IZ ;-).\r
+;;; Some bugs under XEmacs introduced by the correction corrected.\r
+\r
+;;; Some more can remain since there are two many different variants.\r
+;;; Please feedback!\r
+\r
+;;; We do not support fontification of arrays and hashes under\r
+;;; obsolete font-lock any more. Upgrade.\r
+\r
+;;;; after 1.8 Minor bug with parentheses.\r
+;;;; after 1.9 Improvements from Joe Marzot.\r
+;;;; after 1.10\r
+;;; Does not need easymenu to compile under XEmacs.\r
+;;; `vc-insert-headers' should work better.\r
+;;; Should work with 19.29 and 19.12.\r
+;;; Small improvements to fontification.\r
+;;; Expansion of keywords does not depend on C-? being backspace.\r
+\r
+;;; after 1.10+\r
+;;; 19.29 and 19.12 supported.\r
+;;; `cperl-font-lock-enhanced' deprecated. Use font-lock-extra.el.\r
+;;; Support for font-lock-extra.el.\r
+\r
+;;;; After 1.11:\r
+;;; Tools submenu.\r
+;;; Support for perl5-info.\r
+;;; `imenu-go-find-at-position' in Tools requires imenu-go.el (see hints above)\r
+;;; Imenu entries do not work with stock imenu.el. Patch sent to maintainers.\r
+;;; Fontifies `require a if b;', __DATA__.\r
+;;; Arglist for auto-fill-mode was incorrect.\r
+\r
+;;;; After 1.12:\r
+;;; `cperl-lineup-step' and `cperl-lineup' added: lineup constructions\r
+;;; vertically.\r
+;;; `cperl-do-auto-fill' updated for 19.29 style.\r
+;;; `cperl-info-on-command' now has a default.\r
+;;; Workaround for broken C-h on XEmacs.\r
+;;; VC strings escaped.\r
+;;; C-h f now may prompt for function name instead of going on,\r
+;;; controlled by `cperl-info-on-command-no-prompt'.\r
+\r
+;;;; After 1.13:\r
+;;; Msb buffer list includes perl files\r
+;;; Indent-for-comment uses indent-to\r
+;;; Can write tag files using etags.\r
+\r
+;;;; After 1.14:\r
+;;; Recognizes (tries to ;-) {...} which are not blocks during indentation.\r
+;;; `cperl-close-paren-offset' affects ?\] too (and ?\} if not block)\r
+;;; Bug with auto-filling comments started with "##" corrected.\r
+\r
+;;;; Very slow now: on DB::DB 0.91, 486/66:\r
+\r
+;;;Function Name Call Count Elapsed Time Average Time\r
+;;;======================================== ========== ============ ============\r
+;;;cperl-block-p 469 3.7799999999 0.0080597014\r
+;;;cperl-get-state 505 163.39000000 0.3235445544\r
+;;;cperl-comment-indent 12 0.0299999999 0.0024999999\r
+;;;cperl-backward-to-noncomment 939 4.4599999999 0.0047497337\r
+;;;cperl-calculate-indent 505 172.22000000 0.3410297029\r
+;;;cperl-indent-line 505 172.88000000 0.3423366336\r
+;;;cperl-use-region-p 40 0.0299999999 0.0007499999\r
+;;;cperl-indent-exp 1 177.97000000 177.97000000\r
+;;;cperl-to-comment-or-eol 1453 3.9800000000 0.0027391603\r
+;;;cperl-backward-to-start-of-continued-exp 9 0.0300000000 0.0033333333\r
+;;;cperl-indent-region 1 177.94000000 177.94000000\r
+\r
+;;;; After 1.15:\r
+;;; Takes into account white space after opening parentheses during indent.\r
+;;; May highlight pods and here-documents: see `cperl-pod-here-scan',\r
+;;; `cperl-pod-here-fontify', `cperl-pod-face'. Does not use this info\r
+;;; for indentation so far.\r
+;;; Fontification updated to 19.30 style.\r
+;;; The change 19.29->30 did not add all the required functionality,\r
+;;; but broke "font-lock-extra.el". Get "choose-color.el" from\r
+;;; ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs\r
+\r
+;;;; After 1.16:\r
+;;; else # comment\r
+;;; recognized as a start of a block.\r
+;;; Two different font-lock-levels provided.\r
+;;; `cperl-pod-head-face' introduced. Used for highlighting.\r
+;;; `imenu' marks pods, +Packages moved to the head.\r
+\r
+;;;; After 1.17:\r
+;;; Scan for pods highlights here-docs too.\r
+;;; Note that the tag of here-doc may be rehighlighted later by lazy-lock.\r
+;;; Only one here-doc-tag per line is supported, and one in comment\r
+;;; or a string may break fontification.\r
+;;; POD headers were supposed to fill one line only.\r
+\r
+;;;; After 1.18:\r
+;;; `font-lock-keywords' were set in 19.30 style _always_. Current scheme\r
+;;; may break under XEmacs.\r
+;;; `cperl-calculate-indent' dis suppose that `parse-start' was defined.\r
+;;; `fontified' tag is added to fontified text as well as `lazy-lock' (for\r
+;;; compatibility with older lazy-lock.el) (older one overfontifies\r
+;;; something nevertheless :-().\r
+;;; Will not indent something inside pod and here-documents.\r
+;;; Fontifies the package name after import/no/bootstrap.\r
+;;; Added new entry to menu with meta-info about the mode.\r
+\r
+;;;; After 1.19:\r
+;;; Prefontification works much better with 19.29. Should be checked\r
+;;; with 19.30 as well.\r
+;;; Some misprints in docs corrected.\r
+;;; Now $a{-text} and -text => "blah" are fontified as strings too.\r
+;;; Now the pod search is much stricter, so it can help you to find\r
+;;; pod sections which are broken because of whitespace before =blah\r
+;;; - just observe the fontification.\r
+\r
+;;;; After 1.20\r
+;;; Anonymous subs are indented with respect to the level of\r
+;;; indentation of `sub' now.\r
+;;; {} is recognized as hash after `bless' and `return'.\r
+;;; Anonymous subs are split by `cperl-linefeed' as well.\r
+;;; Electric parens embrace a region if present.\r
+;;; To make `cperl-auto-newline' useful,\r
+;;; `cperl-auto-newline-after-colon' is introduced.\r
+;;; `cperl-electric-parens' is now t or nul. The old meaning is moved to\r
+;;; `cperl-electric-parens-string'.\r
+;;; `cperl-toggle-auto-newline' introduced, put on C-c C-a.\r
+;;; `cperl-toggle-abbrev' introduced, put on C-c C-k.\r
+;;; `cperl-toggle-electric' introduced, put on C-c C-e.\r
+;;; Beginning-of-defun-regexp was not anchored.\r
+\r
+;;;; After 1.21\r
+;;; Auto-newline grants `cperl-extra-newline-before-brace' if "{" is typed\r
+;;; after ")".\r
+;;; {} is recognized as expression after `tr' and friends.\r
+\r
+;;;; After 1.22\r
+;;; Entry Hierarchy added to imenu. Very primitive so far.\r
+;;; One needs newer `imenu-go'.el. A patch to `imenu' is needed as well.\r
+;;; Writes its own TAGS files.\r
+;;; Class viewer based on TAGS files. Does not trace @ISA so far.\r
+;;; 19.31: Problems with scan for PODs corrected.\r
+;;; First POD header correctly fontified.\r
+;;; I needed (setq imenu-use-keymap-menu t) to get good imenu in 19.31.\r
+;;; Apparently it makes a lot of hierarchy code obsolete...\r
+\r
+;;;; After 1.23\r
+;;; Tags filler now scans *.xs as well.\r
+;;; The info from *.xs scan is used by the hierarchy viewer.\r
+;;; Hierarchy viewer documented.\r
+;;; Bug in 19.31 imenu documented.\r
+\r
+;;;; After 1.24\r
+;;; New location for info-files mentioned,\r
+;;; Electric-; should work better.\r
+;;; Minor bugs with POD marking.\r
+\r
+;;;; After 1.25 (probably not...)\r
+;;; `cperl-info-page' introduced.\r
+;;; To make `uncomment-region' working, `comment-region' would\r
+;;; not insert extra space.\r
+;;; Here documents delimiters better recognized\r
+;;; (empty one, and non-alphanums in quotes handled). May be wrong with 1<<14?\r
+;;; `cperl-db' added, used in menu.\r
+;;; imenu scan removes text-properties, for better debugging\r
+;;; - but the bug is in 19.31 imenu.\r
+;;; formats highlighted by font-lock and prescan, embedded comments\r
+;;; are not treated.\r
+;;; POD/friends scan merged in one pass.\r
+;;; Syntax class is not used for analyzing the code, only char-syntax\r
+;;; may be checked against _ or'ed with w.\r
+;;; Syntax class of `:' changed to be _.\r
+;;; `cperl-find-bad-style' added.\r
+\r
+;;;; After 1.25\r
+;;; When search for here-documents, we ignore commented << in simplest cases.\r
+;;; `cperl-get-help' added, available on C-h v and from menu.\r
+;;; Auto-help added. Default with `cperl-hairy', switchable on/off\r
+;;; with startup variable `cperl-lazy-help-time' and from\r
+;;; menu. Requires `run-with-idle-timer'.\r
+;;; Highlighting of @abc{@efg} was wrong - interchanged two regexps.\r
+\r
+;;;; After 1.27\r
+;;; Indentation: At toplevel after a label - fixed.\r
+;;; 1.27 was put to archives in binary mode ===> DOSish :-(\r
+\r
+;;;; After 1.28\r
+;;; Thanks to Martin Buchholz <mrb@Eng.Sun.COM>: misprints in\r
+;;; comments and docstrings corrected, XEmacs support cleaned up.\r
+;;; The closing parenths would enclose the region into matching\r
+;;; parens under the same conditions as the opening ones.\r
+;;; Minor updates to `cperl-short-docs'.\r
+;;; Will not consider <<= as start of here-doc.\r
+\r
+;;;; After 1.29\r
+;;; Added an extra advice to look into Micro-docs. ;-).\r
+;;; Enclosing of region when you press a closing parenth is regulated by\r
+;;; `cperl-electric-parens-string'.\r
+;;; Minor updates to `cperl-short-docs'.\r
+;;; `initialize-new-tags-table' called only if present (Does this help\r
+;;; with generation of tags under XEmacs?).\r
+;;; When creating/updating tag files, new info is written at the old place,\r
+;;; or at the end (is this a wanted behaviour? I need this in perl build directory).\r
+\r
+;;;; After 1.30\r
+;;; All the keywords from keywords.pl included (maybe with dummy explanation).\r
+;;; No auto-help inside strings, comment, here-docs, formats, and pods.\r
+;;; Shrinkwrapping of info, regulated by `cperl-max-help-size',\r
+;;; `cperl-shrink-wrap-info-frame'.\r
+;;; Info on variables as well.\r
+;;; Recognision of HERE-DOCS improved yet more.\r
+;;; Autonewline works on `}' without warnings.\r
+;;; Autohelp works again on $_[0].\r
+\r
+;;;; After 1.31\r
+;;; perl-descr.el found its author - hi, Johan!\r
+;;; Some support for correct indent after here-docs and friends (may\r
+;;; be superseeded by eminent change to Emacs internals).\r
+;;; Should work with older Emaxen as well ( `-style stuff removed).\r
+\r
+;;;; After 1.32\r
+\r
+;;; Started to add support for `syntax-table' property (should work\r
+;;; with patched Emaxen), controlled by\r
+;;; `cperl-use-syntax-table-text-property'. Currently recognized:\r
+;;; All quote-like operators: m, s, y, tr, qq, qw, qx, q,\r
+;;; // in most frequent context:\r
+;;; after block or\r
+;;; ~ { ( = | & + - * ! , ;\r
+;;; or\r
+;;; while if unless until and or not xor split grep map\r
+;;; Here-documents, formats, PODs,\r
+;;; ${...}\r
+;;; 'abc$'\r
+;;; sub a ($); sub a ($) {}\r
+;;; (provide 'cperl-mode) was missing!\r
+;;; `cperl-after-expr-p' is now much smarter after `}'.\r
+;;; `cperl-praise' added to mini-docs.\r
+;;; Utilities try to support subs-with-prototypes.\r
+\r
+;;;; After 1.32.1\r
+;;; `cperl-after-expr-p' is now much smarter after "() {}" and "word {}":\r
+;;; if word is "else, map, grep".\r
+;;; Updated for new values of syntax-table constants.\r
+;;; Uses `help-char' (at last!) (disabled, does not work?!)\r
+;;; A couple of regexps where missing _ in character classes.\r
+;;; -s could be considered as start of regexp, 1../blah/ was not,\r
+;;; as was not /blah/ at start of file.\r
+\r
+;;;; After 1.32.2\r
+;;; "\C-hv" was wrongly "\C-hf"\r
+;;; C-hv was not working on `[index()]' because of [] in skip-chars-*.\r
+;;; `__PACKAGE__' supported.\r
+;;; Thanks for Greg Badros: `cperl-lazy-unstall' is more complete,\r
+;;; `cperl-get-help' is made compatible with `query-replace'.\r
+\r
+;;;; As of Apr 15, development version of 19.34 supports\r
+;;;; `syntax-table' text properties. Try setting\r
+;;;; `cperl-use-syntax-table-text-property'.\r
+\r
+;;;; After 1.32.3\r
+;;; We scan for s{}[] as well (in simplest situations).\r
+;;; We scan for $blah'foo as well.\r
+;;; The default is to use `syntax-table' text property if Emacs is good enough.\r
+;;; `cperl-lineup' is put on C-M-| (=C-M-S-\\).\r
+;;; Start of `cperl-beautify-regexp'.\r
+\r
+;;;; After 1.32.4\r
+;;; `cperl-tags-hier-init' did not work in text-mode.\r
+;;; `cperl-noscan-files-regexp' had a misprint.\r
+;;; Generation of Class Hierarchy was broken due to a bug in `x-popup-menu'\r
+;;; in 19.34.\r
+\r
+;;;; After 1.33:\r
+;;; my,local highlight vars after {} too.\r
+;;; TAGS could not be created before imenu was loaded.\r
+;;; `cperl-indent-left-aligned-comments' created.\r
+;;; Logic of `cperl-indent-exp' changed a little bit, should be more\r
+;;; robust w.r.t. multiline strings.\r
+;;; Recognition of blah'foo takes into account strings.\r
+;;; Added '.al' to the list of Perl extensions.\r
+;;; Class hierarchy is "mostly" sorted (need to rethink algorthm\r
+;;; of pruning one-root-branch subtrees to get yet better sorting.)\r
+;;; Regeneration of TAGS was busted.\r
+;;; Can use `syntax-table' property when generating TAGS\r
+;;; (governed by `cperl-use-syntax-table-text-property-for-tags').\r
+\r
+;;;; After 1.35:\r
+;;; Can process several =pod/=cut sections one after another.\r
+;;; Knows of `extproc' when under `emx', indents with `__END__' and `__DATA__'.\r
+;;; `cperl-under-as-char' implemented (XEmacs people like broken behaviour).\r
+;;; Beautifier for regexps fixed.\r
+;;; `cperl-beautify-level', `cperl-contract-level' coded\r
+;;;\r
+;;;; Emacs's 20.2 problems:\r
+;;; `imenu.el' has bugs, `imenu-add-to-menubar' does not work.\r
+;;; Couple of others problems with 20.2 were reported, my ability to check/fix\r
+;;; them is very reduced now.\r
+\r
+;;;; After 1.36:\r
+;;; 'C-M-|' in XEmacs fixed\r
+\r
+;;;; After 1.37:\r
+;;; &&s was not recognized as start of regular expression;\r
+;;; Will "preprocess" the contents of //e part of s///e too;\r
+;;; What to do with s# blah # foo #e ?\r
+;;; Should handle s;blah;foo;; better.\r
+;;; Now the only known problems with regular expression recognition:\r
+;;;;;;; s<foo>/bar/ - different delimiters (end ignored)\r
+;;;;;;; s/foo/\\bar/ - backslash at start of subst (made into one chunk)\r
+;;;;;;; s/foo// - empty subst (made into one chunk + '/')\r
+;;;;;;; s/foo/(bar)/ - start-group at start of subst (internal group will not match backwards)\r
+\r
+;;;; After 1.38:\r
+;;; We highlight closing / of s/blah/foo/e;\r
+;;; This handles s# blah # foo #e too;\r
+;;; s//blah/, s///, s/blah// works again, and s#blah## too, the algorithm\r
+;;; is much simpler now;\r
+;;; Next round of changes: s\\\ works, s<blah>/foo/,\r
+;;; comments between the first and the second part allowed\r
+;;; Another problem discovered:\r
+;;;;;;; s[foo] <blah>e - e part delimited by different <> (will not match)\r
+;;; `cperl-find-pods-heres' somehow maybe called when string-face is undefined\r
+;;; - put a stupid workaround for 20.1\r
+\r
+;;;; After 1.39:\r
+;;; Could indent here-docs for comments;\r
+;;; These problems fixed:\r
+;;;;;;; s/foo/\\bar/ - backslash at start of subst (made into two chunk)\r
+;;;;;;; s[foo] <blah>e - "e" part delimited by "different" <> (will match)\r
+;;; Matching brackets honor prefices, may expand abbreviations;\r
+;;; When expanding abbrevs, will remove last char only after\r
+;;; self-inserted whitespace;\r
+;;; More convenient "Refress hard constructs" in menu;\r
+;;; `cperl-add-tags-recurse', `cperl-add-tags-recurse-noxs'\r
+;;; added (for -batch mode);\r
+;;; Better handling of errors when scanning for Perl constructs;\r
+;;;;;;; Possible "problem" with class hierarchy in Perl distribution\r
+;;;;;;; directory: ./ext duplicates ./lib;\r
+;;; Write relative paths for generated TAGS;\r
+\r
+;;;; After 1.40:\r
+;;; s /// may be separated by "\n\f" too;\r
+;;; `s #blah' recognized as a comment;\r
+;;; Would highlight s/abc//s wrong;\r
+;;; Debugging code in `cperl-electric-keywords' was leaking a message;\r
+\r
+;;;; After 1.41:\r
+;;; RMS changes for 20.3 merged\r
+\r
+;;;; 2.0.1.0: RMS mode (has 3 misprints)\r
+\r
+;;;; After 2.0:\r
+;;; RMS whitespace changes for 20.3 merged\r
+\r
+;;;; After 2.1:\r
+;;; History updated\r
+\r
+;;;; After 2.2:\r
+;;; Merge `c-style-alist' since `c-mode' is no more. (Somebody who\r
+;;; uses the styles should check that they work OK!)\r
+;;; All the variable warnings go away, some undef functions too.\r
+\r
+;;;; After 2.3:\r
+;;; Added `cperl-perldoc' (thanks to Anthony Foiani <afoiani@uswest.com>)\r
+;;; Added `cperl-pod-to-manpage' (thanks to Nick Roberts <Nick.Roberts@src.bae.co.uk>)\r
+;;; All the function warnings go away.\r
+\r
+;;;; After 2.4:\r
+;;; `Perl doc', `Regexp' submenus created (latter to allow short displays).\r
+;;; `cperl-clobber-lisp-bindings' added.\r
+;;; $a->y() is not y///.\r
+;;; `cperl-after-block-p' was missing a `save-excursion' => wrong results.\r
+;;; `cperl-val' was defined too late.\r
+;;; `cperl-init-faces' was failing.\r
+;;; Init faces when loading `ps-print'.\r
+\r
+;;;; After 2.4:\r
+;;; `cperl-toggle-autohelp' implemented.\r
+;;; `while SPACE LESS' was buggy.\r
+;;; `-text' in `[-text => 1]' was not highlighted.\r
+;;; `cperl-after-block-p' was FALSE after `sub f {}'.\r
+\r
+;;;; After 2.5:\r
+;;; `foreachmy', `formy' expanded too.\r
+;;; Expand `=pod-directive'.\r
+;;; `cperl-linefeed' behaves reasonable in POD-directive lines.\r
+;;; `cperl-electric-keyword' prints a message, governed by\r
+;;; `cperl-message-electric-keyword'.\r
+\r
+;;;; After 2.6:\r
+;;; Typing `}' was not checking for being block or not.\r
+;;; Beautifying levels in RE: Did not know about lookbehind;\r
+;;; finding *which* level was not intuitive;\r
+;;; `cperl-beautify-levels' added.\r
+;;; Allow here-docs contain `=head1' and friends (at least for keywords).\r
+\r
+;;;; After 2.7:\r
+;;; Fix for broken `font-lock-unfontify-region-function'. Should\r
+;;; preserve `syntax-table' properties even with `lazy-lock'.\r
+\r
+;;;; After 2.8:\r
+;;; Some more compile time warnings crept in.\r
+;;; `cperl-indent-region-fix-else' implemented.\r
+;;; `cperl-fix-line-spacing' implemented.\r
+;;; `cperl-invert-if-unless' implemented (C-c C-t and in Menu).\r
+;;; Upgraded hints to mention 20.2's goods/bads.\r
+;;; Started to use `cperl-extra-newline-before-brace-multiline',\r
+;;; `cperl-break-one-line-blocks-when-indent',\r
+;;; `cperl-fix-hanging-brace-when-indent', `cperl-merge-trailing-else'.\r
+\r
+;;;; After 2.9:\r
+;;; Workaround for another `font-lock's `syntax-table' text-property bug.\r
+;;; `zerop' could be applied to nil.\r
+;;; At last, may work with `font-lock' without setting `cperl-font-lock'.\r
+;;; (We expect that starting from 19.33, `font-lock' supports keywords\r
+;;; being a function - what is a correct version?)\r
+;;; Rename `cperl-indent-region-fix-else' to\r
+;;; `cperl-indent-region-fix-constructs'.\r
+;;; `cperl-fix-line-spacing' could be triggered inside strings, would not\r
+;;; know what to do with BLOCKs of map/printf/etc.\r
+;;; `cperl-merge-trailing-else' and `cperl-fix-line-spacing' handle\r
+;;; `continue' too.\r
+;;; Indentation after {BLOCK} knows about map/printf/etc.\r
+;;; Finally: treat after-comma lines as continuation lines.\r
+\r
+;;;; After 2.10:\r
+;;; `continue' made electric.\r
+;;; Electric `do' inserts `do/while'.\r
+;;; Some extra compile-time warnings crept in.\r
+;;; `font-lock' of 19.33 could not handle font-lock-keywords being a function\r
+;;; returning a symbol.\r
+\r
+;;;; After 2.11:\r
+;;; Changes to make syntaxification to be autoredone via `font-lock'.\r
+;;; Switched on by `cperl-syntaxify-by-font-lock', off by default so far.\r
+\r
+;;;; After 2.12:\r
+;;; Remove some commented out chunks.\r
+;;; Styles are slightly updated (a lot of work is needed, especially\r
+;;; with new `cperl-fix-line-spacing').\r
+\r
+;;;; After 2.13:\r
+;;; Old value of style is memorized when choosing a new style, may be\r
+;;; restored from the same menu.\r
+;;; Mode-documentation added to micro-docs.\r
+;;; `cperl-praise' updated.\r
+;;; `cperl-toggle-construct-fix' added on C-c C-w and menu.\r
+;;; `auto-fill-mode' added on C-c C-f and menu.\r
+;;; `PerlStyle' style added.\r
+;;; Message for termination of scan corrected.\r
+\r
+;;;; After 2.14:\r
+\r
+;;; Did not work with -q\r
+\r
+;;;; After 2.15:\r
+\r
+;;; `cperl-speed' hints added.\r
+;;; Minor style fixes.\r
+\r
+;;;; After 2.15:\r
+;;; Make backspace electric after expansion of `else/continue' too.\r
+\r
+;;;; After 2.16:\r
+;;; Starting to merge changes to RMS emacs version.\r
+\r
+;;;; After 2.17:\r
+;;; Merged custom stuff and darn `font-lock-constant-face'.\r
+\r
+;;;; After 2.18:\r
+;;; Bumped the version to 3.1\r
+\r
+;;;; After 3.1:\r
+;;; Fixed customization to honor cperl-hairy.\r
+;;; Created customization groups. Sent to RMS to include into 2.3.\r
+\r
+;;;; After 3.2:\r
+;;; Interaction of `font-lock-hot-pass' and `cperl-syntaxify-by-font-lock'.\r
+;;; (`cperl-after-block-and-statement-beg'):\r
+;;; (`cperl-after-block-p'):\r
+;;; (`cperl-after-expr-p'): It is BLOCK if we reach lim when backup sexp.\r
+;;; (`cperl-indent-region'): Make a marker for END - text added/removed.\r
+;;; (`cperl-style-alist', `cperl-styles-entries')\r
+;;; Include `cperl-merge-trailing-else' where the value is clear.\r
+\r
+;;;; After 3.3:\r
+;;; (`cperl-tips'):\r
+;;; (`cperl-problems'): Improvements to docs.\r
+\r
+;;;; After 3.4:\r
+;;; (`cperl-mode'): Make lazy syntaxification possible.\r
+;;; (`cperl-find-pods-heres'): Safe a position in buffer where it is safe to\r
+;;; restart syntaxification.\r
+;;; (`cperl-syntaxify-by-font-lock'): Set to t, should be safe now.\r
+\r
+;;;; After 3.5:\r
+;;; (`cperl-syntaxify-by-font-lock'): Better default, customizes to\r
+;;; `message' too.\r
+\r
+;;;; After 3.6:\r
+;;; (`cperl-find-pods-heres'): changed so that -d ?foo? is a RE.\r
+;;; (`cperl-array-face'): changed name from `font-lock-emphasized-face'.\r
+;;; (`cperl-hash-face'): changed name from `font-lock-other-emphasized-face'.\r
+;;; Use `defface' to define these two extra faces.\r
+\r
+;;;; After 3.7:\r
+;;; Can use linear algorithm for indentation if Emacs supports it:\r
+;;; indenting DB::DB (800+ lines) improved from 69 sec to 11 sec\r
+;;; (73 vs 15 with imenu).\r
+;;; (`cperl-emacs-can-parse'): New state.\r
+;;; (`cperl-indent-line'): Corrected to use global state.\r
+;;; (`cperl-calculate-indent'): Likewise.\r
+;;; (`cperl-fix-line-spacing'): Likewise (not used yet).\r
+\r
+;;;; After 3.8:\r
+;;; (`cperl-choose-color'): Converted to a function (to be compilable in text-mode).\r
+\r
+;;;; After 3.9:\r
+;;; (`cperl-dark-background '): Disable without window-system.\r
+\r
+;;;; After 3.10:\r
+;;; Do `defface' only if window-system.\r
+\r
+;;;; After 3.11:\r
+;;; (`cperl-fix-line-spacing'): sped up to bail out early.\r
+;;; (`cperl-indent-region'): Disable hooks during the call (how to call them later?).\r
+\r
+;;; Now indents 820-line-long function in 6.5 sec (including syntaxification) the first time\r
+;;; (when buffer has few properties), 7.1 sec the second time.\r
+\r
+;;;Function Name Call Count Elapsed Time Average Time\r
+;;;========================================= ========== ============ ============\r
+;;;cperl-indent-exp 1 10.039999999 10.039999999\r
+;;;cperl-indent-region 1 10.0 10.0\r
+;;;cperl-indent-line 821 6.2100000000 0.0075639464\r
+;;;cperl-calculate-indent 821 5.0199999999 0.0061144945\r
+;;;cperl-backward-to-noncomment 2856 2.0500000000 0.0007177871\r
+;;;cperl-fontify-syntaxically 2 1.78 0.8900000000\r
+;;;cperl-find-pods-heres 2 1.78 0.8900000000\r
+;;;cperl-update-syntaxification 1 1.78 1.78\r
+;;;cperl-fix-line-spacing 769 1.4800000000 0.0019245773\r
+;;;cperl-after-block-and-statement-beg 163 1.4100000000 0.0086503067\r
+;;;cperl-block-p 775 1.1800000000 0.0015225806\r
+;;;cperl-to-comment-or-eol 3652 1.1200000000 0.0003066812\r
+;;;cperl-after-block-p 165 1.0500000000 0.0063636363\r
+;;;cperl-commentify 141 0.22 0.0015602836\r
+;;;cperl-get-state 813 0.16 0.0001968019\r
+;;;cperl-backward-to-start-of-continued-exp 26 0.12 0.0046153846\r
+;;;cperl-delay-update-hook 2107 0.0899999999 4.271...e-05\r
+;;;cperl-protect-defun-start 141 0.0700000000 0.0004964539\r
+;;;cperl-after-label 407 0.0599999999 0.0001474201\r
+;;;cperl-forward-re 139 0.0299999999 0.0002158273\r
+;;;cperl-comment-indent 26 0.0299999999 0.0011538461\r
+;;;cperl-use-region-p 8 0.0 0.0\r
+;;;cperl-lazy-hook 15 0.0 0.0\r
+;;;cperl-after-expr-p 8 0.0 0.0\r
+;;;cperl-font-lock-unfontify-region-function 1 0.0 0.0\r
+\r
+;;;Function Name Call Count Elapsed Time Average Time\r
+;;;========================================= ========== ============ ============\r
+;;;cperl-fix-line-spacing 769 1.4500000000 0.0018855656\r
+;;;cperl-indent-line 13 0.3100000000 0.0238461538\r
+;;;cperl-after-block-and-statement-beg 69 0.2700000000 0.0039130434\r
+;;;cperl-after-block-p 69 0.2099999999 0.0030434782\r
+;;;cperl-calculate-indent 13 0.1000000000 0.0076923076\r
+;;;cperl-backward-to-noncomment 177 0.0700000000 0.0003954802\r
+;;;cperl-get-state 13 0.0 0.0\r
+;;;cperl-to-comment-or-eol 179 0.0 0.0\r
+;;;cperl-get-help-defer 1 0.0 0.0\r
+;;;cperl-lazy-hook 11 0.0 0.0\r
+;;;cperl-after-expr-p 2 0.0 0.0\r
+;;;cperl-block-p 13 0.0 0.0\r
+;;;cperl-after-label 5 0.0 0.0\r
+\r
+;;;; After 3.12:\r
+;;; (`cperl-find-pods-heres'): do not warn on `=cut' if doing a chunk only.\r
+\r
+;;;; After 3.13:\r
+;;; (`cperl-mode'): load pseudo-faces on `cperl-find-pods-heres' (for 19.30).\r
+;;; (`x-color-defined-p'): was not compiling on XEmacs\r
+;;; (`cperl-find-pods-heres'): 1 << 6 was OK, but 1<<6 was considered as HERE\r
+;;; <file/glob> made into a string.\r
+\r
+;;;; After 3.14:\r
+;;; (`cperl-find-pods-heres'): Postpone addition of faces after syntactic step\r
+;;; Recognition of <FH> was wrong.\r
+;;; (`cperl-clobber-lisp-bindings'): if set, C-c variants are the old ones\r
+;;; (`cperl-unwind-to-safe'): New function.\r
+;;; (`cperl-fontify-syntaxically'): Use `cperl-unwind-to-safe' to start at reasonable position.\r
+\r
+;;;; After 3.15:\r
+;;; (`cperl-forward-re'): Highlight the trailing / in s/foo// as string.\r
+;;; Highlight the starting // in s//foo/ as function-name.\r
+\r
+;;;; After 3.16:\r
+;;; (`cperl-find-pods-heres'): Highlight `gem' in s///gem as a keyword.\r
+\r
+;;;; After 4.0:\r
+;;; (`cperl-find-pods-heres'): `qr' added\r
+;;; (`cperl-electric-keyword'): Likewise\r
+;;; (`cperl-electric-else'): Likewise\r
+;;; (`cperl-to-comment-or-eol'): Likewise\r
+;;; (`cperl-make-regexp-x'): Likewise\r
+;;; (`cperl-init-faces'): Likewise, and `lock' (as overridable?).\r
+;;; (`cperl-find-pods-heres'): Knows that split// is null-RE.\r
+;;; Highlights separators in 3-parts expressions\r
+;;; as labels.\r
+\r
+;;;; After 4.1:\r
+;;; (`cperl-find-pods-heres'): <> was considered as a glob\r
+;;; (`cperl-syntaxify-unwind'): New configuration variable\r
+;;; (`cperl-fontify-m-as-s'): New configuration variable\r
+\r
+;;;; After 4.2:\r
+;;; (`cperl-find-pods-heres'): of the last line being `=head1' fixed.\r
+\r
+;;; Handling of a long construct is still buggy if only the part of\r
+;;; construct touches the updated region (we unwind to the start of\r
+;;; long construct, but the end may have residual properties).\r
+\r
+;;; (`cperl-unwind-to-safe'): would not go to beginning of buffer.\r
+;;; (`cperl-electric-pod'): check for after-expr was performed\r
+;;; inside of POD too.\r
+\r
+;;;; After 4.3:\r
+;;; (`cperl-backward-to-noncomment'): better treatment of PODs and HEREs.\r
+\r
+;;; Indent-line works good, but indent-region does not - at toplevel...\r
+;;; (`cperl-unwind-to-safe'): Signature changed.\r
+;;; (`x-color-defined-p'): was defmacro'ed with a tick. Remove another def.\r
+;;; (`cperl-clobber-mode-lists'): New configuration variable.\r
+;;; (`cperl-array-face'): One of definitions was garbled.\r
+\r
+;;;; After 4.4:\r
+;;; (`cperl-not-bad-style-regexp'): Updated.\r
+;;; (`cperl-make-regexp-x'): Misprint in a message.\r
+;;; (`cperl-find-pods-heres'): $a-1 ? foo : bar; was a regexp.\r
+;;; `<< (' was considered a start of POD.\r
+;;; Init: `cperl-is-face' was busted.\r
+;;; (`cperl-make-face'): New macros.\r
+;;; (`cperl-force-face'): New macros.\r
+;;; (`cperl-init-faces'): Corrected to use new macros;\r
+;;; `if' for copying `reference-face' to\r
+;;; `constant-face' was backward.\r
+;;; (`font-lock-other-type-face'): Done via `defface' too.\r
+\r
+;;;; After 4.5:\r
+;;; (`cperl-init-faces-weak'): use `cperl-force-face'.\r
+;;; (`cperl-after-block-p'): After END/BEGIN we are a block.\r
+;;; (`cperl-mode'): `font-lock-unfontify-region-function'\r
+;;; was set to a wrong function.\r
+;;; (`cperl-comment-indent'): Commenting __END__ was not working.\r
+;;; (`cperl-indent-for-comment'): Likewise.\r
+;;; (Indenting is still misbehaving at toplevel.)\r
+\r
+;;;; After 4.5:\r
+;;; (`cperl-unwind-to-safe'): Signature changed, unwinds end too.\r
+;;; (`cperl-find-pods-heres'): mark qq[]-etc sections as syntax-type=string\r
+;;; (`cperl-fontify-syntaxically'): Unwinds start and end to go out of\r
+;;; long strings (not very successful).\r
+\r
+;;; >>>> CPerl should be usable in write mode too now <<<<\r
+\r
+;;; (`cperl-syntaxify-by-font-lock'): Better default - off in text-mode.\r
+;;; (`cperl-tips'): Updated docs.\r
+;;; (`cperl-problems'): Updated docs.\r
+\r
+;;;; After 4.6:\r
+;;; (`cperl-calculate-indent'): Did not consider `,' as continuation mark for statements.\r
+;;; (`cperl-write-tags'): Correct for XEmacs's `visit-tags-table-buffer'.\r
+\r
+;;;; After 4.7:\r
+;;; (`cperl-calculate-indent'): Avoid parse-data optimization at toplevel.\r
+;;; Should indent correctly at toplevel too.\r
+;;; (`cperl-tags-hier-init'): Gross hack to pretend we work (are we?).\r
+;;; (`cperl-find-pods-heres'): Was not processing sub protos after a comment ine.\r
+;;; Was treating $a++ <= 5 as a glob.\r
+\r
+;;;; After 4.8:\r
+;;; (toplevel): require custom unprotected => failure on 19.28.\r
+;;; (`cperl-xemacs-p') defined when compile too\r
+;;; (`cperl-tags-hier-init'): Another try to work around XEmacs problems\r
+;;; Better progress messages.\r
+;;; (`cperl-find-tags'): Was writing line/pos in a wrong order,\r
+;;; pos off by 1 and not at beg-of-line.\r
+;;; (`cperl-etags-snarf-tag'): New macro\r
+;;; (`cperl-etags-goto-tag-location'): New macro\r
+;;; (`cperl-write-tags'): When removing old TAGS info was not\r
+;;; relativizing filename\r
+\r
+;;;; After 4.9:\r
+;;; (`cperl-version'): New variable. New menu entry\r
+\r
+;;;; After 4.10:\r
+;;; (`cperl-tips'): Updated.\r
+;;; (`cperl-non-problems'): Updated.\r
+;;; random: References to future 20.3 removed.\r
+\r
+;;;; After 4.11:\r
+;;; (`perl-font-lock-keywords'): Would not highlight `sub foo($$);'.\r
+;;; Docstrings: Menu was described as `CPerl' instead of `Perl'\r
+\r
+;;;; After 4.12:\r
+;;; (`cperl-toggle-construct-fix'): Was toggling to t instead of 1.\r
+;;; (`cperl-ps-print-init'): Associate `cperl-array-face', `cperl-hash-face'\r
+;;; remove `font-lock-emphasized-face'.\r
+;;; remove `font-lock-other-emphasized-face'.\r
+;;; remove `font-lock-reference-face'.\r
+;;; remove `font-lock-keyword-face'.\r
+;;; Use `eval-after-load'.\r
+;;; (`cperl-init-faces'): remove init `font-lock-other-emphasized-face'.\r
+;;; remove init `font-lock-emphasized-face'.\r
+;;; remove init `font-lock-keyword-face'.\r
+;;; (`cperl-tips-faces'): New variable and an entry into Mini-docs.\r
+;;; (`cperl-indent-region'): Do not indent whitespace lines\r
+;;; (`cperl-indent-exp'): Was not processing else-blocks.\r
+;;; (`cperl-calculate-indent'): Remove another parse-data optimization\r
+;;; at toplevel: would indent correctly.\r
+;;; (`cperl-get-state'): NOP line removed.\r
+\r
+;;;; After 4.13:\r
+;;; (`cperl-ps-print-init'): Remove not-CPerl-related faces.\r
+;;; (`cperl-ps-print'): New function and menu entry.\r
+;;; (`cperl-ps-print-face-properties'): New configuration variable.\r
+;;; (`cperl-invalid-face'): New configuration variable.\r
+;;; (`cperl-nonoverridable-face'): New face. Renamed from\r
+;;; `font-lock-other-type-face'.\r
+;;; (`perl-font-lock-keywords'): Highlight trailing whitespace\r
+;;; (`cperl-contract-levels'): Documentation corrected.\r
+;;; (`cperl-contract-level'): Likewise.\r
+\r
+;;;; After 4.14:\r
+;;; (`cperl-ps-print'): `ps-print-face-extension-alist' was not in old Emaxen,\r
+;;; same with `ps-extend-face-list'\r
+;;; (`cperl-ps-extend-face-list'): New macro.\r
+\r
+;;;; After 4.15:\r
+;;; (`cperl-init-faces'): Interpolate `cperl-invalid-face'.\r
+;;; (`cperl-forward-re'): Emit a meaningful error instead of a cryptic\r
+;;; one for uncomplete REx near end-of-buffer.\r
+;;; (`cperl-find-pods-heres'): Tolerate unfinished REx at end-of-buffer.\r
+\r
+;;;; After 4.16:\r
+;;; (`cperl-find-pods-heres'): `unwind-protect' was left commented.\r
+\r
+;;;; After 4.17:\r
+;;; (`cperl-invalid-face'): Change to ''underline.\r
+\r
+;;;; After 4.18:\r
+;;; (`cperl-find-pods-heres'): / and ? after : start a REx.\r
+;;; (`cperl-after-expr-p'): Skip labels when checking\r
+;;; (`cperl-calculate-indent'): Correct for labels when calculating\r
+;;; indentation of continuations.\r
+;;; Docstring updated.\r
+\r
+;;;; After 4.19:\r
+;;; Minor (mostly spelling) corrections from 20.3.3 merged.\r
+\r
+;;;; After 4.20:\r
+;;; (`cperl-tips'): Another workaround added. Sent to RMS for 20.4.\r
+\r
+;;;; After 4.21:\r
+;;; (`cperl-praise'): Mention linear-time indent.\r
+;;; (`cperl-find-pods-heres'): @if ? a : b was considered a REx.\r
+\r
+;;;; After 4.22:\r
+;;; (`cperl-after-expr-p'): Make true after __END__.\r
+;;; (`cperl-electric-pod'): "SYNOPSIS" was misspelled.\r
+\r
+;;;; After 4.23:\r
+;;; (`cperl-beautify-regexp-piece'): Was not allowing for *? after a class.\r
+;;; Allow for POSIX char-classes.\r
+;;; Remove trailing whitespace when\r
+;;; adding new linebreak.\r
+;;; Add a level counter to stop shallow.\r
+;;; Indents unprocessed groups rigidly.\r
+;;; (`cperl-beautify-regexp'): Add an optional count argument to go that\r
+;;; many levels deep.\r
+;;; (`cperl-beautify-level'): Likewise\r
+;;; Menu: Add new entries to Regexp menu to do one level\r
+;;; (`cperl-contract-level'): Was entering an infinite loop\r
+;;; (`cperl-find-pods-heres'): Typo (double quoting).\r
+;;; Was detecting < $file > as FH instead of glob.\r
+;;; Support for comments in RExen (except\r
+;;; for m#\#comment#x), governed by\r
+;;; `cperl-regexp-scan'.\r
+;;; (`cperl-regexp-scan'): New customization variable.\r
+;;; (`cperl-forward-re'): Improve logic of resetting syntax table.\r
+\r
+;;;; After 4.23 and: After 4.24:\r
+;;; (`cperl-contract-levels'): Restore position.\r
+;;; (`cperl-beautify-level'): Likewise.\r
+;;; (`cperl-beautify-regexp'): Likewise.\r
+;;; (`cperl-commentify'): Rudimental support for length=1 runs\r
+;;; (`cperl-find-pods-heres'): Process 1-char long REx comments too /a#/x\r
+;;; Processes REx-comments in #-delimited RExen.\r
+;;; MAJOR BUG CORRECTED: after a misparse\r
+;;; a body of a subroutine could be corrupted!!!\r
+;;; One might need to reeval the function body\r
+;;; to fix things. (A similar bug was\r
+;;; present in `cperl-indent-region' eons ago.)\r
+;;; To reproduce:\r
+;; (defun foo () (let ((a '(t))) (insert (format "%s" a)) (setcar a 'BUG) t))\r
+;; (foo)\r
+;; (foo)\r
+;;; C-x C-e the above three lines (at end-of-line). First evaluation\r
+;;; of `foo' inserts (t), second one inserts (BUG) ?!\r
+;;;\r
+;;; In CPerl it was triggered by inserting then deleting `/' at start of\r
+;;; / a (?# asdf {[(}asdf )ef,/;\r
+\r
+;;;; After 4.25:\r
+;;; (`cperl-commentify'): Was recognizing length=2 "strings" as length=1.\r
+;;; (`imenu-example--create-perl-index'):\r
+;;; Was not enforcing syntaxification-to-the-end.\r
+;;; (`cperl-invert-if-unless'): Allow `for', `foreach'.\r
+;;; (`cperl-find-pods-heres'): Quote `cperl-nonoverridable-face'.\r
+;;; Mark qw(), m()x as indentable.\r
+;;; (`cperl-init-faces'): Highlight `sysopen' too.\r
+;;; Highlight $var in `for my $var' too.\r
+;;; (`cperl-invert-if-unless'): Was leaving whitespace at end.\r
+;;; (`cperl-linefeed'): Was splitting $var{$foo} if point after `{'.\r
+;;; (`cperl-calculate-indent'): Remove old commented out code.\r
+;;; Support (primitive) indentation of qw(), m()x.\r
+\r
+\r
+;;;; After 4.26:\r
+;;; (`cperl-problems'): Mention `fill-paragraph' on comment. \"" and\r
+;;; q [] with intervening newlines.\r
+;;; (`cperl-autoindent-on-semi'): New customization variable.\r
+;;; (`cperl-electric-semi'): Use `cperl-autoindent-on-semi'.\r
+;;; (`cperl-tips'): Mention how to make CPerl the default mode.\r
+;;; (`cperl-mode'): Support `outline-minor-mode'\r
+;;; (Thanks to Mark A. Hershberger).\r
+;;; (`cperl-outline-level'): New function.\r
+;;; (`cperl-highlight-variables-indiscriminately'): New customization var.\r
+;;; (`cperl-init-faces'): Use `cperl-highlight-variables-indiscriminately'.\r
+;;; (Thanks to Sean Kamath <kamath@pogo.wv.tek.com>).\r
+;;; (`cperl-after-block-p'): Support CHECK and INIT.\r
+;;; (`cperl-init-faces'): Likewise and "our".\r
+;;; (Thanks to Doug MacEachern <dougm@covalent.net>).\r
+;;; (`cperl-short-docs'): Likewise and "our".\r
+\r
+\r
+;;;; After 4.27:\r
+;;; (`cperl-find-pods-heres'): Recognize \"" as a string.\r
+;;; Mark whitespace and comments between q and []\r
+;;; as `syntax-type' => `prestring'.\r
+;;; Allow whitespace between << and "FOO".\r
+;;; (`cperl-problems'): Remove \"" and q [] with intervening newlines.\r
+;;; Mention multiple <<EOF as unsupported.\r
+;;; (`cperl-highlight-variables-indiscriminately'): Doc misprint fixed.\r
+;;; (`cperl-indent-parens-as-block'): New configuration variable.\r
+;;; (`cperl-calculate-indent'): Merge cases of indenting non-BLOCK groups.\r
+;;; Use `cperl-indent-parens-as-block'.\r
+;;; (`cperl-find-pods-heres'): Test for =cut without empty line instead of\r
+;;; complaining about no =cut.\r
+;;; (`cperl-electric-pod'): Change the REx for POD from "\n\n=" to "^\n=".\r
+;;; (`cperl-find-pods-heres'): Likewise.\r
+;;; (`cperl-electric-pod'): Change `forward-sexp' to `forward-word':\r
+;;; POD could've been marked as comment already.\r
+;;; (`cperl-unwind-to-safe'): Unwind before start of POD too.\r
+\r
+;;;; After 4.28:\r
+;;; (`cperl-forward-re'): Throw an error at proper moment REx unfinished.\r
+\r
+;;;; After 4.29:\r
+;;; (`x-color-defined-p'): Make an extra case to peacify the warning.\r
+;;; Toplevel: `defvar' to peacify the warnings.\r
+;;; (`cperl-find-pods-heres'): Could access `font-lock-comment-face' in -nw.\r
+;;;; No -nw-compile time warnings now.\r
+;;; (`cperl-find-tags'): TAGS file had too short substring-to-search.\r
+;;; Be less verbose in non-interactive mode\r
+;;; (`imenu-example--create-perl-index'): Set index-marker after name\r
+;;; (`cperl-outline-regexp'): New variable.\r
+;;; (`cperl-outline-level'): Made compatible with `cperl-outline-regexp'.\r
+;;; (`cperl-mode'): Made use `cperl-outline-regexp'.\r
+\r
+;;;; After 4.30:\r
+;;; (`cperl-find-pods-heres'): =cut the last thing, no blank line, was error.\r
+;;; (`cperl-outline-level'): Make start-of-file same level as `package'.\r
+\r
+;;;; After 4.31:\r
+;;; (`cperl-electric-pod'): `head1' and `over' electric only if empty.\r
+;;; (`cperl-unreadable-ok'): New variable.\r
+;;; (`cperl-find-tags'): Use `cperl-unreadable-ok', do not fail\r
+;;; on an unreadable file\r
+;;; (`cperl-write-tags'): Use `cperl-unreadable-ok', do not fail\r
+;;; on an unreadable directory\r
+\r
+;;;; After 4.32:\r
+;;; Syncronized with v1.60 from Emacs 21.3.\r
+;;; Mostly docstring and formatting changes, and:\r
+\r
+;;; (`cperl-noscan-files-regexp'): Do not scan CVS subdirs\r
+;;; (`cperl-problems'): Note that newer XEmacsen may syntaxify too\r
+;;; (`imenu-example--create-perl-index'):\r
+;;; Renamed to `cperl-imenu--create-perl-index'\r
+;;; (`cperl-mode'): Replace `make-variable-buffer-local' by `make-local-variable'\r
+;;; (`cperl-setup-tmp-buf'): Likewise\r
+;;; (`cperl-fix-line-spacing'): Fix a misprint of "t" for "\t"\r
+;;; (`cperl-next-bad-style'): Fix misprints in character literals\r
+\r
+;;;; After 4.33:\r
+;;; (`cperl-font-lock-keywords'): +etc: Aliased to perl-font-lock-keywords.\r
+\r
+;;;; After 4.34:\r
+;;; Further updates of whitespace and spelling w.r.t. RMS version.\r
+;;; (`cperl-font-lock-keywords'): +etc: Avoid warnings when aliasing.\r
+;;; (`cperl-mode'): Use `normal-auto-fill-function' if present.\r
+;;; (`cperl-use-major-mode'): New variable\r
+;;; (`cperl-can-font-lock'): New variable; replaces `window-system'\r
+;;; (`cperl-tags-hier-init'): use `display-popup-menus-p' (if present)\r
+;;; to choose `x-popup-menu' vs `tmm-prompt'\r
+\r
+;;;; 4.35 has the following differences from version 1.40+ of RMS Emacs:\r
+\r
+;;; New variables `cperl-use-major-mode', `cperl-can-font-lock';\r
+;;; `cperl-use-major-mode' is (effectively) 'cperl-mode in RMS.\r
+;;; `cperl-under-as-char' is nil in RMS.\r
+;;; Minor differences in docstrings, and `cperl-non-problems'.\r
+;;; Backward compatibility addressed: (`); (function (lambda ...)); font-lock;\r
+;;; (:italic t bold t) vs (:slant italic :weight bold) in faces;\r
+;;; `normal-auto-fill-function'.\r
+;;; RMS version has wrong logic in `cperl-calculate-indent': $a = { } is\r
+;;; wrongly indented if the closing brace is on a separate line.\r
+;;; Different choice of ordering if's for is-x-REx and (eq (char-after b) ?\#)\r
+;;; in `cperl-find-pods-heres'. [Cosmetic]\r
+\r
+;;;; After 4.35:\r
+;;; (`cperl-find-pods-heres'): If no end of HERE-doc found, mark to the end\r
+;;; of buffer. This enables recognition of end\r
+;;; of HERE-doc "as one types".\r
+;;; Require "\n" after trailing tag of HERE-doc.\r
+;;; \( made non-quoting outside of string/comment\r
+;;; (gdj-contributed).\r
+;;; Likewise for \$.\r
+;;; Remove `here-doc-group' text property at start\r
+;;; (makes this property reliable).\r
+;;; Text property `first-format-line' ==> t.\r
+;;; Do not recognize $opt_s and $opt::s as s///.\r
+;;; (`cperl-perldoc'): Use case-sensitive search (contributed).\r
+;;; (`cperl-fix-line-spacing'): Allow "_" in $vars of foreach etc. when\r
+;;; underscore isn't a word char (gdj-contributed).\r
+;;; (`defun-prompt-regexp'): Allow prototypes.\r
+;;; (`cperl-vc-header-alist'): Extract numeric version from the Id.\r
+;;; Toplevel: Put toggle-autohelp into the mode menu.\r
+;;; Better docs for toggle/set/unset autohelp.\r
+;;; (`cperl-electric-backspace-untabify'): New customization variable\r
+;;; (`cperl-after-expr-p'): Works after here-docs, formats, and PODs too\r
+;;; (affects many electric constructs).\r
+;;; (`cperl-calculate-indent'): Takes into account `first-format-line' ==>\r
+;;; works after format.\r
+;;; (`cperl-short-docs'): Make it work with ... too.\r
+;;; "array context" ==> "list context"\r
+;;; (`cperl-electric-keyword'): make $if (etc: "$@%&*") non-electric\r
+;;; '(' after keyword would insert a doubled paren\r
+;;; (`cperl-electric-paren'): documented affected by `cperl-electric-parens'\r
+;;; (`cperl-electric-rparen'): Likewise\r
+;;; (`cperl-build-manpage'): New function by Nick Roberts\r
+;;; (`cperl-perldoc'): Make it work in XEmacs too\r
+\r
+;;;; After 4.36:\r
+;;; (`cperl-find-pods-heres'): Recognize s => 1 and {s} (as a key or varname),\r
+;;; { s:: } and { s::bar::baz } as varnames.\r
+;;; (`cperl-after-expr-p'): Updates syntaxification before checks\r
+;;; (`cperl-calculate-indent'): Likewise\r
+;;; Fix wrong indent of blocks starting with POD\r
+;;; (`cperl-after-block-p'): Optional argument for checking for a pre-block\r
+;;; Recognize `continue' blocks too.\r
+;;; (`cperl-electric-brace'): use `cperl-after-block-p' for detection;\r
+;;; Now works for else/continue/sub blocks\r
+;;; (`cperl-short-docs'): Minor edits; make messages fit 80-column screen\r
+\r
+;;; Code:\r
+\r
+\f\r
+(if (fboundp 'eval-when-compile)\r
+ (eval-when-compile\r
+ (condition-case nil\r
+ (require 'custom)\r
+ (error nil))\r
+ (condition-case nil\r
+ (require 'man)\r
+ (error nil))\r
+ (defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version))\r
+ (defvar cperl-can-font-lock\r
+ (or cperl-xemacs-p\r
+ (and (boundp 'emacs-major-version)\r
+ (or window-system\r
+ (> emacs-major-version 20)))))\r
+ (if cperl-can-font-lock\r
+ (require 'font-lock))\r
+ (defvar msb-menu-cond)\r
+ (defvar gud-perldb-history)\r
+ (defvar font-lock-background-mode) ; not in Emacs\r
+ (defvar font-lock-display-type) ; ditto\r
+ (or (fboundp 'defgroup)\r
+ (defmacro defgroup (name val doc &rest arr)\r
+ nil))\r
+ (or (fboundp 'custom-declare-variable)\r
+ (defmacro defcustom (name val doc &rest arr)\r
+ (` (defvar (, name) (, val) (, doc)))))\r
+ (or (and (fboundp 'custom-declare-variable)\r
+ (string< "19.31" emacs-version)) ; Checked with 19.30: defface does not work\r
+ (defmacro defface (&rest arr)\r
+ nil))\r
+ ;; Avoid warning (tmp definitions)\r
+ (or (fboundp 'x-color-defined-p)\r
+ (defmacro x-color-defined-p (col)\r
+ (cond ((fboundp 'color-defined-p) (` (color-defined-p (, col))))\r
+ ;; XEmacs >= 19.12\r
+ ((fboundp 'valid-color-name-p) (` (valid-color-name-p (, col))))\r
+ ;; XEmacs 19.11\r
+ ((fboundp 'x-valid-color-name-p) (` (x-valid-color-name-p (, col))))\r
+ (t '(error "Cannot implement color-defined-p")))))\r
+ (defmacro cperl-is-face (arg) ; Takes quoted arg\r
+ (cond ((fboundp 'find-face)\r
+ (` (find-face (, arg))))\r
+ (;;(and (fboundp 'face-list)\r
+ ;; (face-list))\r
+ (fboundp 'face-list)\r
+ (` (member (, arg) (and (fboundp 'face-list)\r
+ (face-list)))))\r
+ (t\r
+ (` (boundp (, arg))))))\r
+ (defmacro cperl-make-face (arg descr) ; Takes unquoted arg\r
+ (cond ((fboundp 'make-face)\r
+ (` (make-face (quote (, arg)))))\r
+ (t\r
+ (` (defvar (, arg) (quote (, arg)) (, descr))))))\r
+ (defmacro cperl-force-face (arg descr) ; Takes unquoted arg\r
+ (` (progn\r
+ (or (cperl-is-face (quote (, arg)))\r
+ (cperl-make-face (, arg) (, descr)))\r
+ (or (boundp (quote (, arg))) ; We use unquoted variants too\r
+ (defvar (, arg) (quote (, arg)) (, descr))))))\r
+ (if cperl-xemacs-p\r
+ (defmacro cperl-etags-snarf-tag (file line)\r
+ (` (progn\r
+ (beginning-of-line 2)\r
+ (list (, file) (, line)))))\r
+ (defmacro cperl-etags-snarf-tag (file line)\r
+ (` (etags-snarf-tag))))\r
+ (if cperl-xemacs-p\r
+ (defmacro cperl-etags-goto-tag-location (elt)\r
+ (`;;(progn\r
+ ;; (switch-to-buffer (get-file-buffer (elt (, elt) 0)))\r
+ ;; (set-buffer (get-file-buffer (elt (, elt) 0)))\r
+ ;; Probably will not work due to some save-excursion???\r
+ ;; Or save-file-position?\r
+ ;; (message "Did I get to line %s?" (elt (, elt) 1))\r
+ (goto-line (string-to-int (elt (, elt) 1)))))\r
+ ;;)\r
+ (defmacro cperl-etags-goto-tag-location (elt)\r
+ (` (etags-goto-tag-location (, elt)))))))\r
+\r
+(defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version))\r
+\r
+(defvar cperl-can-font-lock\r
+ (or cperl-xemacs-p\r
+ (and (boundp 'emacs-major-version)\r
+ (or window-system\r
+ (> emacs-major-version 20)))))\r
+\r
+(condition-case nil\r
+ (require 'custom)\r
+ (error nil)) ; Already fixed by eval-when-compile\r
+\r
+(defun cperl-choose-color (&rest list)\r
+ (let (answer)\r
+ (while list\r
+ (or answer\r
+ (if (or (x-color-defined-p (car list))\r
+ (null (cdr list)))\r
+ (setq answer (car list))))\r
+ (setq list (cdr list)))\r
+ answer))\r
+\r
+\f\r
+(defgroup cperl nil\r
+ "Major mode for editing Perl code."\r
+ :prefix "cperl-"\r
+ :group 'languages)\r
+\r
+(defgroup cperl-indentation-details nil\r
+ "Indentation."\r
+ :prefix "cperl-"\r
+ :group 'cperl)\r
+\r
+(defgroup cperl-affected-by-hairy nil\r
+ "Variables affected by `cperl-hairy'."\r
+ :prefix "cperl-"\r
+ :group 'cperl)\r
+\r
+(defgroup cperl-autoinsert-details nil\r
+ "Auto-insert tuneup."\r
+ :prefix "cperl-"\r
+ :group 'cperl)\r
+\r
+(defgroup cperl-faces nil\r
+ "Fontification colors."\r
+ :prefix "cperl-"\r
+ :group 'cperl)\r
+\r
+(defgroup cperl-speed nil\r
+ "Speed vs. validity tuneup."\r
+ :prefix "cperl-"\r
+ :group 'cperl)\r
+\r
+(defgroup cperl-help-system nil\r
+ "Help system tuneup."\r
+ :prefix "cperl-"\r
+ :group 'cperl)\r
+\r
+\f\r
+(defcustom cperl-extra-newline-before-brace nil\r
+ "*Non-nil means that if, elsif, while, until, else, for, foreach\r
+and do constructs look like:\r
+\r
+ if ()\r
+ {\r
+ }\r
+\r
+instead of:\r
+\r
+ if () {\r
+ }"\r
+ :type 'boolean\r
+ :group 'cperl-autoinsert-details)\r
+\r
+(defcustom cperl-extra-newline-before-brace-multiline\r
+ cperl-extra-newline-before-brace\r
+ "*Non-nil means the same as `cperl-extra-newline-before-brace', but\r
+for constructs with multiline if/unless/while/until/for/foreach condition."\r
+ :type 'boolean\r
+ :group 'cperl-autoinsert-details)\r
+\r
+(defcustom cperl-indent-level 2\r
+ "*Indentation of CPerl statements with respect to containing block."\r
+ :type 'integer\r
+ :group 'cperl-indentation-details)\r
+\r
+(defcustom cperl-lineup-step nil\r
+ "*`cperl-lineup' will always lineup at multiple of this number.\r
+If nil, the value of `cperl-indent-level' will be used."\r
+ :type '(choice (const nil) integer)\r
+ :group 'cperl-indentation-details)\r
+\r
+(defcustom cperl-brace-imaginary-offset 0\r
+ "*Imagined indentation of a Perl open brace that actually follows a statement.\r
+An open brace following other text is treated as if it were this far\r
+to the right of the start of its line."\r
+ :type 'integer\r
+ :group 'cperl-indentation-details)\r
+\r
+(defcustom cperl-brace-offset 0\r
+ "*Extra indentation for braces, compared with other text in same context."\r
+ :type 'integer\r
+ :group 'cperl-indentation-details)\r
+(defcustom cperl-label-offset -2\r
+ "*Offset of CPerl label lines relative to usual indentation."\r
+ :type 'integer\r
+ :group 'cperl-indentation-details)\r
+(defcustom cperl-min-label-indent 1\r
+ "*Minimal offset of CPerl label lines."\r
+ :type 'integer\r
+ :group 'cperl-indentation-details)\r
+(defcustom cperl-continued-statement-offset 2\r
+ "*Extra indent for lines not starting new statements."\r
+ :type 'integer\r
+ :group 'cperl-indentation-details)\r
+(defcustom cperl-continued-brace-offset 0\r
+ "*Extra indent for substatements that start with open-braces.\r
+This is in addition to cperl-continued-statement-offset."\r
+ :type 'integer\r
+ :group 'cperl-indentation-details)\r
+(defcustom cperl-close-paren-offset -1\r
+ "*Extra indent for substatements that start with close-parenthesis."\r
+ :type 'integer\r
+ :group 'cperl-indentation-details)\r
+\r
+(defcustom cperl-auto-newline nil\r
+ "*Non-nil means automatically newline before and after braces,\r
+and after colons and semicolons, inserted in CPerl code. The following\r
+\\[cperl-electric-backspace] will remove the inserted whitespace.\r
+Insertion after colons requires both this variable and\r
+`cperl-auto-newline-after-colon' set."\r
+ :type 'boolean\r
+ :group 'cperl-autoinsert-details)\r
+\r
+(defcustom cperl-autoindent-on-semi nil\r
+ "*Non-nil means automatically indent after insertion of (semi)colon.\r
+Active if `cperl-auto-newline' is false."\r
+ :type 'boolean\r
+ :group 'cperl-autoinsert-details)\r
+\r
+(defcustom cperl-auto-newline-after-colon nil\r
+ "*Non-nil means automatically newline even after colons.\r
+Subject to `cperl-auto-newline' setting."\r
+ :type 'boolean\r
+ :group 'cperl-autoinsert-details)\r
+\r
+(defcustom cperl-tab-always-indent t\r
+ "*Non-nil means TAB in CPerl mode should always reindent the current line,\r
+regardless of where in the line point is when the TAB command is used."\r
+ :type 'boolean\r
+ :group 'cperl-indentation-details)\r
+\r
+(defcustom cperl-font-lock nil\r
+ "*Non-nil (and non-null) means CPerl buffers will use `font-lock-mode'.\r
+Can be overwritten by `cperl-hairy' if nil."\r
+ :type '(choice (const null) boolean)\r
+ :group 'cperl-affected-by-hairy)\r
+\r
+(defcustom cperl-electric-lbrace-space nil\r
+ "*Non-nil (and non-null) means { after $ should be preceded by ` '.\r
+Can be overwritten by `cperl-hairy' if nil."\r
+ :type '(choice (const null) boolean)\r
+ :group 'cperl-affected-by-hairy)\r
+\r
+(defcustom cperl-electric-parens-string "({[]})<"\r
+ "*String of parentheses that should be electric in CPerl.\r
+Closing ones are electric only if the region is highlighted."\r
+ :type 'string\r
+ :group 'cperl-affected-by-hairy)\r
+\r
+(defcustom cperl-electric-parens nil\r
+ "*Non-nil (and non-null) means parentheses should be electric in CPerl.\r
+Can be overwritten by `cperl-hairy' if nil."\r
+ :type '(choice (const null) boolean)\r
+ :group 'cperl-affected-by-hairy)\r
+\r
+(defvar zmacs-regions) ; Avoid warning\r
+\r
+(defcustom cperl-electric-parens-mark\r
+ (and window-system\r
+ (or (and (boundp 'transient-mark-mode) ; For Emacs\r
+ transient-mark-mode)\r
+ (and (boundp 'zmacs-regions) ; For XEmacs\r
+ zmacs-regions)))\r
+ "*Not-nil means that electric parens look for active mark.\r
+Default is yes if there is visual feedback on mark."\r
+ :type 'boolean\r
+ :group 'cperl-autoinsert-details)\r
+\r
+(defcustom cperl-electric-linefeed nil\r
+ "*If true, LFD should be hairy in CPerl, otherwise C-c LFD is hairy.\r
+In any case these two mean plain and hairy linefeeds together.\r
+Can be overwritten by `cperl-hairy' if nil."\r
+ :type '(choice (const null) boolean)\r
+ :group 'cperl-affected-by-hairy)\r
+\r
+(defcustom cperl-electric-keywords nil\r
+ "*Not-nil (and non-null) means keywords are electric in CPerl.\r
+Can be overwritten by `cperl-hairy' if nil."\r
+ :type '(choice (const null) boolean)\r
+ :group 'cperl-affected-by-hairy)\r
+\r
+(defcustom cperl-electric-backspace-untabify t\r
+ "*Not-nil means electric-backspace will untabify in CPerl."\r
+ :type 'boolean\r
+ :group 'cperl-autoinsert-details)\r
+\r
+(defcustom cperl-hairy nil\r
+ "*Not-nil means most of the bells and whistles are enabled in CPerl.\r
+Affects: `cperl-font-lock', `cperl-electric-lbrace-space',\r
+`cperl-electric-parens', `cperl-electric-linefeed', `cperl-electric-keywords',\r
+`cperl-info-on-command-no-prompt', `cperl-clobber-lisp-bindings',\r
+`cperl-lazy-help-time'."\r
+ :type 'boolean\r
+ :group 'cperl-affected-by-hairy)\r
+\r
+(defcustom cperl-comment-column 32\r
+ "*Column to put comments in CPerl (use \\[cperl-indent] to lineup with code)."\r
+ :type 'integer\r
+ :group 'cperl-indentation-details)\r
+\r
+(defcustom cperl-vc-header-alist '((SCCS "($sccs) = ('%W\%' =~ /(\\d+(\\.\\d+)+)/) ;")\r
+ (RCS "($rcs) = (' $Id\$ ' =~ /(\\d+(\\.\\d+)+)/) ;"))\r
+ "*What to use as `vc-header-alist' in CPerl."\r
+ :type '(repeat (list symbol string))\r
+ :group 'cperl)\r
+\r
+(defcustom cperl-clobber-mode-lists\r
+ (not\r
+ (and\r
+ (boundp 'interpreter-mode-alist)\r
+ (assoc "miniperl" interpreter-mode-alist)\r
+ (assoc "\\.\\([pP][Llm]\\|al\\)$" auto-mode-alist)))\r
+ "*Whether to install us into `interpreter-' and `extension' mode lists."\r
+ :type 'boolean\r
+ :group 'cperl)\r
+\r
+(defcustom cperl-info-on-command-no-prompt nil\r
+ "*Not-nil (and non-null) means not to prompt on C-h f.\r
+The opposite behaviour is always available if prefixed with C-c.\r
+Can be overwritten by `cperl-hairy' if nil."\r
+ :type '(choice (const null) boolean)\r
+ :group 'cperl-affected-by-hairy)\r
+\r
+(defcustom cperl-clobber-lisp-bindings nil\r
+ "*Not-nil (and non-null) means not overwrite C-h f.\r
+The function is available on \\[cperl-info-on-command], \\[cperl-get-help].\r
+Can be overwritten by `cperl-hairy' if nil."\r
+ :type '(choice (const null) boolean)\r
+ :group 'cperl-affected-by-hairy)\r
+\r
+(defcustom cperl-lazy-help-time nil\r
+ "*Not-nil (and non-null) means to show lazy help after given idle time.\r
+Can be overwritten by `cperl-hairy' to be 5 sec if nil."\r
+ :type '(choice (const null) (const nil) integer)\r
+ :group 'cperl-affected-by-hairy)\r
+\r
+(defcustom cperl-pod-face 'font-lock-comment-face\r
+ "*The result of evaluation of this expression is used for POD highlighting."\r
+ :type 'face\r
+ :group 'cperl-faces)\r
+\r
+(defcustom cperl-pod-head-face 'font-lock-variable-name-face\r
+ "*The result of evaluation of this expression is used for POD highlighting.\r
+Font for POD headers."\r
+ :type 'face\r
+ :group 'cperl-faces)\r
+\r
+(defcustom cperl-here-face 'font-lock-string-face\r
+ "*The result of evaluation of this expression is used for here-docs highlighting."\r
+ :type 'face\r
+ :group 'cperl-faces)\r
+\r
+(defcustom cperl-invalid-face ''underline ; later evaluated by `font-lock'\r
+ "*The result of evaluation of this expression highlights trailing whitespace."\r
+ :type 'face\r
+ :group 'cperl-faces)\r
+\r
+(defcustom cperl-pod-here-fontify '(featurep 'font-lock)\r
+ "*Not-nil after evaluation means to highlight POD and here-docs sections."\r
+ :type 'boolean\r
+ :group 'cperl-faces)\r
+\r
+(defcustom cperl-fontify-m-as-s t\r
+ "*Not-nil means highlight 1arg regular expressions operators same as 2arg."\r
+ :type 'boolean\r
+ :group 'cperl-faces)\r
+\r
+(defcustom cperl-highlight-variables-indiscriminately nil\r
+ "*Non-nil means perform additional highlighting on variables.\r
+Currently only changes how scalar variables are highlighted.\r
+Note that that variable is only read at initialization time for\r
+the variable `perl-font-lock-keywords-2', so changing it after you've\r
+entered CPerl mode the first time will have no effect."\r
+ :type 'boolean\r
+ :group 'cperl)\r
+\r
+(defcustom cperl-pod-here-scan t\r
+ "*Not-nil means look for POD and here-docs sections during startup.\r
+You can always make lookup from menu or using \\[cperl-find-pods-heres]."\r
+ :type 'boolean\r
+ :group 'cperl-speed)\r
+\r
+(defcustom cperl-regexp-scan t\r
+ "*Not-nil means make marking of regular expression more thorough.\r
+Effective only with `cperl-pod-here-scan'. Not implemented yet."\r
+ :type 'boolean\r
+ :group 'cperl-speed)\r
+\r
+(defcustom cperl-imenu-addback nil\r
+ "*Not-nil means add backreferences to generated `imenu's.\r
+May require patched `imenu' and `imenu-go'. Obsolete."\r
+ :type 'boolean\r
+ :group 'cperl-help-system)\r
+\r
+(defcustom cperl-max-help-size 66\r
+ "*Non-nil means shrink-wrapping of info-buffer allowed up to these percents."\r
+ :type '(choice integer (const nil))\r
+ :group 'cperl-help-system)\r
+\r
+(defcustom cperl-shrink-wrap-info-frame t\r
+ "*Non-nil means shrink-wrapping of info-buffer-frame allowed."\r
+ :type 'boolean\r
+ :group 'cperl-help-system)\r
+\r
+(defcustom cperl-info-page "perl"\r
+ "*Name of the info page containing perl docs.\r
+Older version of this page was called `perl5', newer `perl'."\r
+ :type 'string\r
+ :group 'cperl-help-system)\r
+\r
+(defcustom cperl-use-syntax-table-text-property\r
+ (boundp 'parse-sexp-lookup-properties)\r
+ "*Non-nil means CPerl sets up and uses `syntax-table' text property."\r
+ :type 'boolean\r
+ :group 'cperl-speed)\r
+\r
+(defcustom cperl-use-syntax-table-text-property-for-tags\r
+ cperl-use-syntax-table-text-property\r
+ "*Non-nil means: set up and use `syntax-table' text property generating TAGS."\r
+ :type 'boolean\r
+ :group 'cperl-speed)\r
+\r
+(defcustom cperl-scan-files-regexp "\\.\\([pP][Llm]\\|xs\\)$"\r
+ "*Regexp to match files to scan when generating TAGS."\r
+ :type 'regexp\r
+ :group 'cperl)\r
+\r
+(defcustom cperl-noscan-files-regexp\r
+ "/\\(\\.\\.?\\|SCCS\\|RCS\\|CVS\\|blib\\)$"\r
+ "*Regexp to match files/dirs to skip when generating TAGS."\r
+ :type 'regexp\r
+ :group 'cperl)\r
+\r
+(defcustom cperl-regexp-indent-step nil\r
+ "*Indentation used when beautifying regexps.\r
+If nil, the value of `cperl-indent-level' will be used."\r
+ :type '(choice integer (const nil))\r
+ :group 'cperl-indentation-details)\r
+\r
+(defcustom cperl-indent-left-aligned-comments t\r
+ "*Non-nil means that the comment starting in leftmost column should indent."\r
+ :type 'boolean\r
+ :group 'cperl-indentation-details)\r
+\r
+(defcustom cperl-under-as-char t\r
+ "*Non-nil means that the _ (underline) should be treated as word char."\r
+ :type 'boolean\r
+ :group 'cperl)\r
+\r
+(defcustom cperl-extra-perl-args ""\r
+ "*Extra arguments to use when starting Perl.\r
+Currently used with `cperl-check-syntax' only."\r
+ :type 'string\r
+ :group 'cperl)\r
+\r
+(defcustom cperl-message-electric-keyword t\r
+ "*Non-nil means that the `cperl-electric-keyword' prints a help message."\r
+ :type 'boolean\r
+ :group 'cperl-help-system)\r
+\r
+(defcustom cperl-indent-region-fix-constructs 1\r
+ "*Amount of space to insert between `}' and `else' or `elsif'\r
+in `cperl-indent-region'. Set to nil to leave as is. Values other\r
+than 1 and nil will probably not work."\r
+ :type '(choice (const nil) (const 1))\r
+ :group 'cperl-indentation-details)\r
+\r
+(defcustom cperl-break-one-line-blocks-when-indent t\r
+ "*Non-nil means that one-line if/unless/while/until/for/foreach BLOCKs\r
+need to be reformatted into multiline ones when indenting a region."\r
+ :type 'boolean\r
+ :group 'cperl-indentation-details)\r
+\r
+(defcustom cperl-fix-hanging-brace-when-indent t\r
+ "*Non-nil means that BLOCK-end `}' may be put on a separate line\r
+when indenting a region.\r
+Braces followed by else/elsif/while/until are excepted."\r
+ :type 'boolean\r
+ :group 'cperl-indentation-details)\r
+\r
+(defcustom cperl-merge-trailing-else t\r
+ "*Non-nil means that BLOCK-end `}' followed by else/elsif/continue\r
+may be merged to be on the same line when indenting a region."\r
+ :type 'boolean\r
+ :group 'cperl-indentation-details)\r
+\r
+(defcustom cperl-indent-parens-as-block nil\r
+ "*Non-nil means that non-block ()-, {}- and []-groups are indented as blocks,\r
+but for trailing \",\" inside the group, which won't increase indentation.\r
+One should tune up `cperl-close-paren-offset' as well."\r
+ :type 'boolean\r
+ :group 'cperl-indentation-details)\r
+\r
+(defcustom cperl-syntaxify-by-font-lock\r
+ (and cperl-can-font-lock\r
+ (boundp 'parse-sexp-lookup-properties))\r
+ "*Non-nil means that CPerl uses `font-lock's routines for syntaxification."\r
+ :type '(choice (const message) boolean)\r
+ :group 'cperl-speed)\r
+\r
+(defcustom cperl-syntaxify-unwind\r
+ t\r
+ "*Non-nil means that CPerl unwinds to a start of a long construction\r
+when syntaxifying a chunk of buffer."\r
+ :type 'boolean\r
+ :group 'cperl-speed)\r
+\r
+(defcustom cperl-ps-print-face-properties\r
+ '((font-lock-keyword-face nil nil bold shadow)\r
+ (font-lock-variable-name-face nil nil bold)\r
+ (font-lock-function-name-face nil nil bold italic box)\r
+ (font-lock-constant-face nil "LightGray" bold)\r
+ (cperl-array-face nil "LightGray" bold underline)\r
+ (cperl-hash-face nil "LightGray" bold italic underline)\r
+ (font-lock-comment-face nil "LightGray" italic)\r
+ (font-lock-string-face nil nil italic underline)\r
+ (cperl-nonoverridable-face nil nil italic underline)\r
+ (font-lock-type-face nil nil underline)\r
+ (underline nil "LightGray" strikeout))\r
+ "List given as an argument to `ps-extend-face-list' in `cperl-ps-print'."\r
+ :type '(repeat (cons symbol\r
+ (cons (choice (const nil) string)\r
+ (cons (choice (const nil) string)\r
+ (repeat symbol)))))\r
+ :group 'cperl-faces)\r
+\r
+(if cperl-can-font-lock\r
+ (progn\r
+ (defvar cperl-dark-background\r
+ (cperl-choose-color "navy" "os2blue" "darkgreen"))\r
+ (defvar cperl-dark-foreground\r
+ (cperl-choose-color "orchid1" "orange"))\r
+\r
+ (defface cperl-nonoverridable-face\r
+ (` ((((class grayscale) (background light))\r
+ (:background "Gray90" :italic t :underline t))\r
+ (((class grayscale) (background dark))\r
+ (:foreground "Gray80" :italic t :underline t :bold t))\r
+ (((class color) (background light))\r
+ (:foreground "chartreuse3"))\r
+ (((class color) (background dark))\r
+ (:foreground (, cperl-dark-foreground)))\r
+ (t (:bold t :underline t))))\r
+ "Font Lock mode face used to highlight array names."\r
+ :group 'cperl-faces)\r
+\r
+ (defface cperl-array-face\r
+ (` ((((class grayscale) (background light))\r
+ (:background "Gray90" :bold t))\r
+ (((class grayscale) (background dark))\r
+ (:foreground "Gray80" :bold t))\r
+ (((class color) (background light))\r
+ (:foreground "Blue" :background "lightyellow2" :bold t))\r
+ (((class color) (background dark))\r
+ (:foreground "yellow" :background (, cperl-dark-background) :bold t))\r
+ (t (:bold t))))\r
+ "Font Lock mode face used to highlight array names."\r
+ :group 'cperl-faces)\r
+\r
+ (defface cperl-hash-face\r
+ (` ((((class grayscale) (background light))\r
+ (:background "Gray90" :bold t :italic t))\r
+ (((class grayscale) (background dark))\r
+ (:foreground "Gray80" :bold t :italic t))\r
+ (((class color) (background light))\r
+ (:foreground "Red" :background "lightyellow2" :bold t :italic t))\r
+ (((class color) (background dark))\r
+ (:foreground "Red" :background (, cperl-dark-background) :bold t :italic t))\r
+ (t (:bold t :italic t))))\r
+ "Font Lock mode face used to highlight hash names."\r
+ :group 'cperl-faces)))\r
+\r
+\f\r
+\r
+;;; Short extra-docs.\r
+\r
+(defvar cperl-tips 'please-ignore-this-line\r
+ "Get maybe newer version of this package from\r
+ ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs\r
+and/or\r
+ ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl\r
+Subdirectory `cperl-mode' may contain yet newer development releases and/or\r
+patches to related files.\r
+\r
+For best results apply to an older Emacs the patches from\r
+ ftp://ftp.math.ohio-state.edu/pub/users/ilya/cperl-mode/patches\r
+\(this upgrades syntax-parsing abilities of RMS Emaxen v19.34 and \r
+v20.2 up to the level of RMS Emacs v20.3 - a must for a good Perl\r
+mode.) As of beginning of 2003, XEmacs may provide a similar ability.\r
+\r
+Get support packages choose-color.el (or font-lock-extra.el before\r
+19.30), imenu-go.el from the same place. \(Look for other files there\r
+too... ;-). Get a patch for imenu.el in 19.29. Note that for 19.30 and\r
+later you should use choose-color.el *instead* of font-lock-extra.el\r
+\(and you will not get smart highlighting in C :-().\r
+\r
+Note that to enable Compile choices in the menu you need to install\r
+mode-compile.el.\r
+\r
+If your Emacs does not default to `cperl-mode' on Perl files, and you\r
+want it to: put the following into your .emacs file:\r
+\r
+ (autoload 'perl-mode \"cperl-mode\" \"alternate mode for editing Perl programs\" t)\r
+\r
+or\r
+\r
+ (defalias 'perl-mode 'cperl-mode)\r
+\r
+Get perl5-info from\r
+ $CPAN/doc/manual/info/perl-info.tar.gz\r
+older version was on\r
+ http://www.metronet.com:70/9/perlinfo/perl5/manual/perl5-info.tar.gz\r
+\r
+If you use imenu-go, run imenu on perl5-info buffer (you can do it\r
+from Perl menu). If many files are related, generate TAGS files from\r
+Tools/Tags submenu in Perl menu.\r
+\r
+If some class structure is too complicated, use Tools/Hierarchy-view\r
+from Perl menu, or hierarchic view of imenu. The second one uses the\r
+current buffer only, the first one requires generation of TAGS from\r
+Perl/Tools/Tags menu beforehand.\r
+\r
+Run Perl/Tools/Insert-spaces-if-needed to fix your lazy typing.\r
+\r
+Switch auto-help on/off with Perl/Tools/Auto-help.\r
+\r
+Though with contemporary Emaxen CPerl mode should maintain the correct\r
+parsing of Perl even when editing, sometimes it may be lost. Fix this by\r
+\r
+ M-x norm RET\r
+\r
+or\r
+\r
+ \\[normal-mode]\r
+\r
+In cases of more severe confusion sometimes it is helpful to do\r
+\r
+ M-x load-l RET cperl-mode RET\r
+ M-x norm RET\r
+\r
+or\r
+\r
+ \\[load-library] cperl-mode RET\r
+ \\[normal-mode]\r
+\r
+Before reporting (non-)problems look in the problem section of online\r
+micro-docs on what I know about CPerl problems.")\r
+\r
+(defvar cperl-problems 'please-ignore-this-line\r
+ "Description of problems in CPerl mode.\r
+Some faces will not be shown on some versions of Emacs unless you\r
+install choose-color.el, available from\r
+ ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs/\r
+\r
+`fill-paragraph' on a comment may leave the point behind the\r
+paragraph. Parsing of lines with several <<EOF is not implemented\r
+yet.\r
+\r
+Emacs had a _very_ restricted syntax parsing engine until RMS's Emacs\r
+20.1. Most problems below are corrected starting from this version of\r
+Emacs, and all of them should be fixed in RMS's version 20.3. (Or apply\r
+patches to Emacs 19.33/34 - see tips.) XEmacs was very backward in\r
+this respect (until 2003).\r
+\r
+Note that even with newer Emacsen in some very rare cases the details\r
+of interaction of `font-lock' and syntaxification may be not cleaned\r
+up yet. You may get slightly different colors basing on the order of\r
+fontification and syntaxification. Say, the initial faces is correct,\r
+but editing the buffer breaks this.\r
+\r
+Even with older Emacsen CPerl mode tries to corrects some Emacs\r
+misunderstandings, however, for efficiency reasons the degree of\r
+correction is different for different operations. The partially\r
+corrected problems are: POD sections, here-documents, regexps. The\r
+operations are: highlighting, indentation, electric keywords, electric\r
+braces.\r
+\r
+This may be confusing, since the regexp s#//#/#\; may be highlighted\r
+as a comment, but it will be recognized as a regexp by the indentation\r
+code. Or the opposite case, when a POD section is highlighted, but\r
+may break the indentation of the following code (though indentation\r
+should work if the balance of delimiters is not broken by POD).\r
+\r
+The main trick (to make $ a \"backslash\") makes constructions like\r
+${aaa} look like unbalanced braces. The only trick I can think of is\r
+to insert it as $ {aaa} (legal in perl5, not in perl4).\r
+\r
+Similar problems arise in regexps, when /(\\s|$)/ should be rewritten\r
+as /($|\\s)/. Note that such a transposition is not always possible.\r
+\r
+The solution is to upgrade your Emacs or patch an older one. Note\r
+that RMS's 20.2 has some bugs related to `syntax-table' text\r
+properties. Patches are available on the main CPerl download site,\r
+and on CPAN.\r
+\r
+If these bugs cannot be fixed on your machine (say, you have an inferior\r
+environment and cannot recompile), you may still disable all the fancy stuff\r
+via `cperl-use-syntax-table-text-property'.")\r
+\r
+(defvar cperl-non-problems 'please-ignore-this-line\r
+"As you know from `problems' section, Perl syntax is too hard for CPerl on \r
+older Emacsen. Here is what you can do if you cannot upgrade, or if\r
+you want to switch off these capabilities on RMS Emacs 20.2 (+patches) or 20.3\r
+or better. Please skip this docs if you run a capable Emacs already.\r
+\r
+Most of the time, if you write your own code, you may find an equivalent\r
+\(and almost as readable) expression (what is discussed below is usually\r
+not relevant on newer Emacsen, since they can do it automatically).\r
+\r
+Try to help CPerl: add comments with embedded quotes to fix CPerl\r
+misunderstandings about the end of quotation:\r
+\r
+$a='500$'; # ';\r
+\r
+You won't need it too often. The reason: $ \"quotes\" the following\r
+character (this saves a life a lot of times in CPerl), thus due to\r
+Emacs parsing rules it does not consider tick (i.e., ' ) after a\r
+dollar as a closing one, but as a usual character. This is usually\r
+correct, but not in the above context.\r
+\r
+Even with older Emacsen the indentation code is pretty wise. The only\r
+drawback is that it relied on Emacs parsing to find matching\r
+parentheses. And Emacs *could not* match parentheses in Perl 100%\r
+correctly. So\r
+ 1 if s#//#/#;\r
+would not break indentation, but\r
+ 1 if ( s#//#/# );\r
+would. Upgrade.\r
+\r
+By similar reasons\r
+ s\"abc\"def\";\r
+could confuse CPerl a lot.\r
+\r
+If you still get wrong indentation in situation that you think the\r
+code should be able to parse, try:\r
+\r
+a) Check what Emacs thinks about balance of your parentheses.\r
+b) Supply the code to me (IZ).\r
+\r
+Pods were treated _very_ rudimentally. Here-documents were not\r
+treated at all (except highlighting and inhibiting indentation). Upgrade.\r
+\r
+To speed up coloring the following compromises exist:\r
+ a) sub in $mypackage::sub may be highlighted.\r
+ b) -z in [a-z] may be highlighted.\r
+ c) if your regexp contains a keyword (like \"s\"), it may be highlighted.\r
+\r
+\r
+Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove\r
+`car' before `imenu-choose-buffer-index' in `imenu'.\r
+`imenu-add-to-menubar' in 20.2 is broken. \r
+A lot of things on XEmacs may be broken too, judging by bug reports I\r
+receive. Note that some releases of XEmacs are better than the others\r
+as far as bugs reports I see are concerned.")\r
+\r
+(defvar cperl-praise 'please-ignore-this-line\r
+ "Advantages of CPerl mode.\r
+\r
+0) It uses the newest `syntax-table' property ;-);\r
+\r
+1) It does 99% of Perl syntax correct (as opposed to 80-90% in Perl\r
+mode - but the latter number may have improved too in last years) even\r
+with old Emaxen which do not support `syntax-table' property.\r
+\r
+When using `syntax-table' property for syntax assist hints, it should\r
+handle 99.995% of lines correct - or somesuch. It automatically\r
+updates syntax assist hints when you edit your script.\r
+\r
+2) It is generally believed to be \"the most user-friendly Emacs\r
+package\" whatever it may mean (I doubt that the people who say similar\r
+things tried _all_ the rest of Emacs ;-), but this was not a lonely\r
+voice);\r
+\r
+3) Everything is customizable, one-by-one or in a big sweep;\r
+\r
+4) It has many easily-accessable \"tools\":\r
+ a) Can run program, check syntax, start debugger;\r
+ b) Can lineup vertically \"middles\" of rows, like `=' in\r
+ a = b;\r
+ cc = d;\r
+ c) Can insert spaces where this impoves readability (in one\r
+ interactive sweep over the buffer);\r
+ d) Has support for imenu, including:\r
+ 1) Separate unordered list of \"interesting places\";\r
+ 2) Separate TOC of POD sections;\r
+ 3) Separate list of packages;\r
+ 4) Hierarchical view of methods in (sub)packages;\r
+ 5) and functions (by the full name - with package);\r
+ e) Has an interface to INFO docs for Perl; The interface is\r
+ very flexible, including shrink-wrapping of\r
+ documentation buffer/frame;\r
+ f) Has a builtin list of one-line explanations for perl constructs.\r
+ g) Can show these explanations if you stay long enough at the\r
+ corresponding place (or on demand);\r
+ h) Has an enhanced fontification (using 3 or 4 additional faces\r
+ comparing to font-lock - basically, different\r
+ namespaces in Perl have different colors);\r
+ i) Can construct TAGS basing on its knowledge of Perl syntax,\r
+ the standard menu has 6 different way to generate\r
+ TAGS (if \"by directory\", .xs files - with C-language\r
+ bindings - are included in the scan);\r
+ j) Can build a hierarchical view of classes (via imenu) basing\r
+ on generated TAGS file;\r
+ k) Has electric parentheses, electric newlines, uses Abbrev\r
+ for electric logical constructs\r
+ while () {}\r
+ with different styles of expansion (context sensitive\r
+ to be not so bothering). Electric parentheses behave\r
+ \"as they should\" in a presence of a visible region.\r
+ l) Changes msb.el \"on the fly\" to insert a group \"Perl files\";\r
+ m) Can convert from\r
+ if (A) { B }\r
+ to\r
+ B if A;\r
+\r
+ n) Highlights (by user-choice) either 3-delimiters constructs\r
+ (such as tr/a/b/), or regular expressions and `y/tr';\r
+ o) Highlights trailing whitespace;\r
+ p) Is able to manipulate Perl Regular Expressions to ease\r
+ conversion to a more readable form.\r
+\r
+5) The indentation engine was very smart, but most of tricks may be\r
+not needed anymore with the support for `syntax-table' property. Has\r
+progress indicator for indentation (with `imenu' loaded).\r
+\r
+6) Indent-region improves inline-comments as well; also corrects\r
+whitespace *inside* the conditional/loop constructs.\r
+\r
+7) Fill-paragraph correctly handles multi-line comments;\r
+\r
+8) Can switch to different indentation styles by one command, and restore\r
+the settings present before the switch.\r
+\r
+9) When doing indentation of control constructs, may correct\r
+line-breaks/spacing between elements of the construct.\r
+\r
+10) Uses a linear-time algorith for indentation of regions (on Emaxen with\r
+capable syntax engines).")\r
+\r
+(defvar cperl-speed 'please-ignore-this-line\r
+ "This is an incomplete compendium of what is available in other parts\r
+of CPerl documentation. (Please inform me if I skept anything.)\r
+\r
+There is a perception that CPerl is slower than alternatives. This part\r
+of documentation is designed to overcome this misconception.\r
+\r
+*By default* CPerl tries to enable the most comfortable settings.\r
+From most points of view, correctly working package is infinitely more\r
+comfortable than a non-correctly working one, thus by default CPerl\r
+prefers correctness over speed. Below is the guide how to change\r
+settings if your preferences are different.\r
+\r
+A) Speed of loading the file. When loading file, CPerl may perform a\r
+scan which indicates places which cannot be parsed by primitive Emacs\r
+syntax-parsing routines, and marks them up so that either\r
+\r
+ A1) CPerl may work around these deficiencies (for big chunks, mostly\r
+ PODs and HERE-documents), or\r
+ A2) On capable Emaxen CPerl will use improved syntax-handlings\r
+ which reads mark-up hints directly.\r
+\r
+ The scan in case A2 is much more comprehensive, thus may be slower.\r
+\r
+ User can disable syntax-engine-helping scan of A2 by setting\r
+ `cperl-use-syntax-table-text-property'\r
+ variable to nil (if it is set to t).\r
+\r
+ One can disable the scan altogether (both A1 and A2) by setting\r
+ `cperl-pod-here-scan'\r
+ to nil.\r
+\r
+B) Speed of editing operations.\r
+\r
+ One can add a (minor) speedup to editing operations by setting\r
+ `cperl-use-syntax-table-text-property'\r
+ variable to nil (if it is set to t). This will disable\r
+ syntax-engine-helping scan, thus will make many more Perl\r
+ constructs be wrongly recognized by CPerl, thus may lead to\r
+ wrongly matched parentheses, wrong indentation, etc.\r
+\r
+ One can unset `cperl-syntaxify-unwind'. This might speed up editing\r
+ of, say, long POD sections.")\r
+\r
+(defvar cperl-tips-faces 'please-ignore-this-line\r
+ "CPerl mode uses following faces for highlighting:\r
+\r
+ `cperl-array-face' Array names\r
+ `cperl-hash-face' Hash names\r
+ `font-lock-comment-face' Comments, PODs and whatever is considered\r
+ syntaxically to be not code\r
+ `font-lock-constant-face' HERE-doc delimiters, labels, delimiters of\r
+ 2-arg operators s/y/tr/ or of RExen,\r
+ `font-lock-function-name-face' Special-cased m// and s//foo/, _ as\r
+ a target of a file tests, file tests,\r
+ subroutine names at the moment of definition\r
+ (except those conflicting with Perl operators),\r
+ package names (when recognized), format names\r
+ `font-lock-keyword-face' Control flow switch constructs, declarators\r
+ `cperl-nonoverridable-face' Non-overridable keywords, modifiers of RExen\r
+ `font-lock-string-face' Strings, qw() constructs, RExen, POD sections,\r
+ literal parts and the terminator of formats\r
+ and whatever is syntaxically considered\r
+ as string literals\r
+ `font-lock-type-face' Overridable keywords\r
+ `font-lock-variable-name-face' Variable declarations, indirect array and\r
+ hash names, POD headers/item names\r
+ `cperl-invalid-face' Trailing whitespace\r
+\r
+Note that in several situations the highlighting tries to inform about\r
+possible confusion, such as different colors for function names in\r
+declarations depending on what they (do not) override, or special cases\r
+m// and s/// which do not do what one would expect them to do.\r
+\r
+Help with best setup of these faces for printout requested (for each of\r
+the faces: please specify bold, italic, underline, shadow and box.)\r
+\r
+\(Not finished.)")\r
+\r
+\f\r
+\r
+;;; Portability stuff:\r
+\r
+(defmacro cperl-define-key (emacs-key definition &optional xemacs-key)\r
+ (` (define-key cperl-mode-map\r
+ (, (if xemacs-key\r
+ (` (if cperl-xemacs-p (, xemacs-key) (, emacs-key)))\r
+ emacs-key))\r
+ (, definition))))\r
+\r
+(defvar cperl-del-back-ch\r
+ (car (append (where-is-internal 'delete-backward-char)\r
+ (where-is-internal 'backward-delete-char-untabify)))\r
+ "Character generated by key bound to `delete-backward-char'.")\r
+\r
+(and (vectorp cperl-del-back-ch) (= (length cperl-del-back-ch) 1)\r
+ (setq cperl-del-back-ch (aref cperl-del-back-ch 0)))\r
+\r
+(defun cperl-mark-active () (mark)) ; Avoid undefined warning\r
+(if cperl-xemacs-p\r
+ (progn\r
+ ;; "Active regions" are on: use region only if active\r
+ ;; "Active regions" are off: use region unconditionally\r
+ (defun cperl-use-region-p ()\r
+ (if zmacs-regions (mark) t)))\r
+ (defun cperl-use-region-p ()\r
+ (if transient-mark-mode mark-active t))\r
+ (defun cperl-mark-active () mark-active))\r
+\r
+(defsubst cperl-enable-font-lock ()\r
+ cperl-can-font-lock)\r
+\r
+(defun cperl-putback-char (c) ; Emacs 19\r
+ (set 'unread-command-events (list c))) ; Avoid undefined warning\r
+\r
+(if (boundp 'unread-command-events)\r
+ (if cperl-xemacs-p\r
+ (defun cperl-putback-char (c) ; XEmacs >= 19.12\r
+ (setq unread-command-events (list (eval '(character-to-event c))))))\r
+ (defun cperl-putback-char (c) ; XEmacs <= 19.11\r
+ (set 'unread-command-event (eval '(character-to-event c))))) ; Avoid warnings\r
+\r
+(or (fboundp 'uncomment-region)\r
+ (defun uncomment-region (beg end)\r
+ (interactive "r")\r
+ (comment-region beg end -1)))\r
+\r
+(defvar cperl-do-not-fontify\r
+ (if (string< emacs-version "19.30")\r
+ 'fontified\r
+ 'lazy-lock)\r
+ "Text property which inhibits refontification.")\r
+\r
+(defsubst cperl-put-do-not-fontify (from to &optional post)\r
+ ;; If POST, do not do it with postponed fontification\r
+ (if (and post cperl-syntaxify-by-font-lock)\r
+ nil\r
+ (put-text-property (max (point-min) (1- from))\r
+ to cperl-do-not-fontify t)))\r
+\r
+(defcustom cperl-mode-hook nil\r
+ "Hook run by CPerl mode."\r
+ :type 'hook\r
+ :group 'cperl)\r
+\r
+(defvar cperl-syntax-state nil)\r
+(defvar cperl-syntax-done-to nil)\r
+(defvar cperl-emacs-can-parse (> (length (save-excursion\r
+ (parse-partial-sexp (point) (point)))) 9))\r
+\f\r
+;; Make customization possible "in reverse"\r
+(defsubst cperl-val (symbol &optional default hairy)\r
+ (cond\r
+ ((eq (symbol-value symbol) 'null) default)\r
+ (cperl-hairy (or hairy t))\r
+ (t (symbol-value symbol))))\r
+\f\r
+;;; Probably it is too late to set these guys already, but it can help later:\r
+\r
+(and cperl-clobber-mode-lists\r
+ (setq auto-mode-alist\r
+ (append '(("\\.\\([pP][Llm]\\|al\\)$" . perl-mode)) auto-mode-alist ))\r
+ (and (boundp 'interpreter-mode-alist)\r
+ (setq interpreter-mode-alist (append interpreter-mode-alist\r
+ '(("miniperl" . perl-mode))))))\r
+(if (fboundp 'eval-when-compile)\r
+ (eval-when-compile\r
+ (mapcar (lambda (p)\r
+ (condition-case nil\r
+ (require p)\r
+ (error nil)))\r
+ '(imenu easymenu etags timer man info))\r
+ (if (fboundp 'ps-extend-face-list)\r
+ (defmacro cperl-ps-extend-face-list (arg)\r
+ (` (ps-extend-face-list (, arg))))\r
+ (defmacro cperl-ps-extend-face-list (arg)\r
+ (` (error "This version of Emacs has no `ps-extend-face-list'"))))\r
+ ;; Calling `cperl-enable-font-lock' below doesn't compile on XEmacs,\r
+ ;; macros instead of defsubsts don't work on Emacs, so we do the\r
+ ;; expansion manually. Any other suggestions?\r
+ (if cperl-can-font-lock\r
+ (require 'font-lock))\r
+ (require 'cl)))\r
+\r
+(defvar cperl-mode-abbrev-table nil\r
+ "Abbrev table in use in CPerl mode buffers.")\r
+\r
+(add-hook 'edit-var-mode-alist '(perl-mode (regexp . "^cperl-")))\r
+\r
+(defvar cperl-mode-map () "Keymap used in CPerl mode.")\r
+\r
+(if cperl-mode-map nil\r
+ (setq cperl-mode-map (make-sparse-keymap))\r
+ (cperl-define-key "{" 'cperl-electric-lbrace)\r
+ (cperl-define-key "[" 'cperl-electric-paren)\r
+ (cperl-define-key "(" 'cperl-electric-paren)\r
+ (cperl-define-key "<" 'cperl-electric-paren)\r
+ (cperl-define-key "}" 'cperl-electric-brace)\r
+ (cperl-define-key "]" 'cperl-electric-rparen)\r
+ (cperl-define-key ")" 'cperl-electric-rparen)\r
+ (cperl-define-key ";" 'cperl-electric-semi)\r
+ (cperl-define-key ":" 'cperl-electric-terminator)\r
+ (cperl-define-key "\C-j" 'newline-and-indent)\r
+ (cperl-define-key "\C-c\C-j" 'cperl-linefeed)\r
+ (cperl-define-key "\C-c\C-t" 'cperl-invert-if-unless)\r
+ (cperl-define-key "\C-c\C-a" 'cperl-toggle-auto-newline)\r
+ (cperl-define-key "\C-c\C-k" 'cperl-toggle-abbrev)\r
+ (cperl-define-key "\C-c\C-w" 'cperl-toggle-construct-fix)\r
+ (cperl-define-key "\C-c\C-f" 'auto-fill-mode)\r
+ (cperl-define-key "\C-c\C-e" 'cperl-toggle-electric)\r
+ (cperl-define-key "\C-c\C-ha" 'cperl-toggle-autohelp)\r
+ (cperl-define-key "\e\C-q" 'cperl-indent-exp) ; Usually not bound\r
+ (cperl-define-key [?\C-\M-\|] 'cperl-lineup\r
+ [(control meta |)])\r
+ ;;(cperl-define-key "\M-q" 'cperl-fill-paragraph)\r
+ ;;(cperl-define-key "\e;" 'cperl-indent-for-comment)\r
+ (cperl-define-key "\177" 'cperl-electric-backspace)\r
+ (cperl-define-key "\t" 'cperl-indent-command)\r
+ ;; don't clobber the backspace binding:\r
+ (cperl-define-key "\C-c\C-hF" 'cperl-info-on-command\r
+ [(control c) (control h) F])\r
+ (if (cperl-val 'cperl-clobber-lisp-bindings)\r
+ (progn\r
+ (cperl-define-key "\C-hf"\r
+ ;;(concat (char-to-string help-char) "f") ; does not work\r
+ 'cperl-info-on-command\r
+ [(control h) f])\r
+ (cperl-define-key "\C-hv"\r
+ ;;(concat (char-to-string help-char) "v") ; does not work\r
+ 'cperl-get-help\r
+ [(control h) v])\r
+ (cperl-define-key "\C-c\C-hf"\r
+ ;;(concat (char-to-string help-char) "f") ; does not work\r
+ (key-binding "\C-hf")\r
+ [(control c) (control h) f])\r
+ (cperl-define-key "\C-c\C-hv"\r
+ ;;(concat (char-to-string help-char) "v") ; does not work\r
+ (key-binding "\C-hv")\r
+ [(control c) (control h) v]))\r
+ (cperl-define-key "\C-c\C-hf" 'cperl-info-on-current-command\r
+ [(control c) (control h) f])\r
+ (cperl-define-key "\C-c\C-hv"\r
+ ;;(concat (char-to-string help-char) "v") ; does not work\r
+ 'cperl-get-help\r
+ [(control c) (control h) v]))\r
+ (if (and cperl-xemacs-p\r
+ (<= emacs-minor-version 11) (<= emacs-major-version 19))\r
+ (progn\r
+ ;; substitute-key-definition is usefulness-deenhanced...\r
+ (cperl-define-key "\M-q" 'cperl-fill-paragraph)\r
+ (cperl-define-key "\e;" 'cperl-indent-for-comment)\r
+ (cperl-define-key "\e\C-\\" 'cperl-indent-region))\r
+ (substitute-key-definition\r
+ 'indent-sexp 'cperl-indent-exp\r
+ cperl-mode-map global-map)\r
+ (substitute-key-definition\r
+ 'fill-paragraph 'cperl-fill-paragraph\r
+ cperl-mode-map global-map)\r
+ (substitute-key-definition\r
+ 'indent-region 'cperl-indent-region\r
+ cperl-mode-map global-map)\r
+ (substitute-key-definition\r
+ 'indent-for-comment 'cperl-indent-for-comment\r
+ cperl-mode-map global-map)))\r
+\r
+(defvar cperl-menu)\r
+(defvar cperl-lazy-installed)\r
+(defvar cperl-old-style nil)\r
+(condition-case nil\r
+ (progn\r
+ (require 'easymenu)\r
+ (easy-menu-define\r
+ cperl-menu cperl-mode-map "Menu for CPerl mode"\r
+ '("Perl"\r
+ ["Beginning of function" beginning-of-defun t]\r
+ ["End of function" end-of-defun t]\r
+ ["Mark function" mark-defun t]\r
+ ["Indent expression" cperl-indent-exp t]\r
+ ["Fill paragraph/comment" cperl-fill-paragraph t]\r
+ "----"\r
+ ["Line up a construction" cperl-lineup (cperl-use-region-p)]\r
+ ["Invert if/unless/while etc" cperl-invert-if-unless t]\r
+ ("Regexp"\r
+ ["Beautify" cperl-beautify-regexp\r
+ cperl-use-syntax-table-text-property]\r
+ ["Beautify one level deep" (cperl-beautify-regexp 1)\r
+ cperl-use-syntax-table-text-property]\r
+ ["Beautify a group" cperl-beautify-level\r
+ cperl-use-syntax-table-text-property]\r
+ ["Beautify a group one level deep" (cperl-beautify-level 1)\r
+ cperl-use-syntax-table-text-property]\r
+ ["Contract a group" cperl-contract-level\r
+ cperl-use-syntax-table-text-property]\r
+ ["Contract groups" cperl-contract-levels\r
+ cperl-use-syntax-table-text-property])\r
+ ["Refresh \"hard\" constructions" cperl-find-pods-heres t]\r
+ "----"\r
+ ["Indent region" cperl-indent-region (cperl-use-region-p)]\r
+ ["Comment region" cperl-comment-region (cperl-use-region-p)]\r
+ ["Uncomment region" cperl-uncomment-region (cperl-use-region-p)]\r
+ "----"\r
+ ["Run" mode-compile (fboundp 'mode-compile)]\r
+ ["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill)\r
+ (get-buffer "*compilation*"))]\r
+ ["Next error" next-error (get-buffer "*compilation*")]\r
+ ["Check syntax" cperl-check-syntax (fboundp 'mode-compile)]\r
+ "----"\r
+ ["Debugger" cperl-db t]\r
+ "----"\r
+ ("Tools"\r
+ ["Imenu" imenu (fboundp 'imenu)]\r
+ ["Insert spaces if needed" cperl-find-bad-style t]\r
+ ["Class Hierarchy from TAGS" cperl-tags-hier-init t]\r
+ ;;["Update classes" (cperl-tags-hier-init t) tags-table-list]\r
+ ["CPerl pretty print (exprmntl)" cperl-ps-print \r
+ (fboundp 'ps-extend-face-list)]\r
+ ["Imenu on info" cperl-imenu-on-info (featurep 'imenu)]\r
+ ("Tags"\r
+;;; ["Create tags for current file" cperl-etags t]\r
+;;; ["Add tags for current file" (cperl-etags t) t]\r
+;;; ["Create tags for Perl files in directory" (cperl-etags nil t) t]\r
+;;; ["Add tags for Perl files in directory" (cperl-etags t t) t]\r
+;;; ["Create tags for Perl files in (sub)directories"\r
+;;; (cperl-etags nil 'recursive) t]\r
+;;; ["Add tags for Perl files in (sub)directories"\r
+;;; (cperl-etags t 'recursive) t])\r
+;;;; cperl-write-tags (&optional file erase recurse dir inbuffer)\r
+ ["Create tags for current file" (cperl-write-tags nil t) t]\r
+ ["Add tags for current file" (cperl-write-tags) t]\r
+ ["Create tags for Perl files in directory"\r
+ (cperl-write-tags nil t nil t) t]\r
+ ["Add tags for Perl files in directory"\r
+ (cperl-write-tags nil nil nil t) t]\r
+ ["Create tags for Perl files in (sub)directories"\r
+ (cperl-write-tags nil t t t) t]\r
+ ["Add tags for Perl files in (sub)directories"\r
+ (cperl-write-tags nil nil t t) t]))\r
+ ("Perl docs"\r
+ ["Define word at point" imenu-go-find-at-position \r
+ (fboundp 'imenu-go-find-at-position)]\r
+ ["Help on function" cperl-info-on-command t]\r
+ ["Help on function at point" cperl-info-on-current-command t]\r
+ ["Help on symbol at point" cperl-get-help t]\r
+ ["Perldoc" cperl-perldoc t]\r
+ ["Perldoc on word at point" cperl-perldoc-at-point t]\r
+ ["View manpage of POD in this file" cperl-build-manpage t]\r
+ ["Auto-help on" cperl-lazy-install \r
+ (and (fboundp 'run-with-idle-timer)\r
+ (not cperl-lazy-installed))]\r
+ ["Auto-help off" cperl-lazy-unstall\r
+ (and (fboundp 'run-with-idle-timer)\r
+ cperl-lazy-installed)])\r
+ ("Toggle..."\r
+ ["Auto newline" cperl-toggle-auto-newline t]\r
+ ["Electric parens" cperl-toggle-electric t]\r
+ ["Electric keywords" cperl-toggle-abbrev t]\r
+ ["Fix whitespace on indent" cperl-toggle-construct-fix t]\r
+ ["Auto-help on Perl constructs" cperl-toggle-autohelp t]\r
+ ["Auto fill" auto-fill-mode t]) \r
+ ("Indent styles..."\r
+ ["CPerl" (cperl-set-style "CPerl") t]\r
+ ["PerlStyle" (cperl-set-style "PerlStyle") t]\r
+ ["GNU" (cperl-set-style "GNU") t]\r
+ ["C++" (cperl-set-style "C++") t]\r
+ ["FSF" (cperl-set-style "FSF") t]\r
+ ["BSD" (cperl-set-style "BSD") t]\r
+ ["Whitesmith" (cperl-set-style "Whitesmith") t]\r
+ ["Current" (cperl-set-style "Current") t]\r
+ ["Memorized" (cperl-set-style-back) cperl-old-style])\r
+ ("Micro-docs"\r
+ ["Tips" (describe-variable 'cperl-tips) t]\r
+ ["Problems" (describe-variable 'cperl-problems) t]\r
+ ["Non-problems" (describe-variable 'cperl-non-problems) t]\r
+ ["Speed" (describe-variable 'cperl-speed) t]\r
+ ["Praise" (describe-variable 'cperl-praise) t]\r
+ ["Faces" (describe-variable 'cperl-tips-faces) t]\r
+ ["CPerl mode" (describe-function 'cperl-mode) t]\r
+ ["CPerl version" \r
+ (message "The version of master-file for this CPerl is %s" \r
+ cperl-version) t]))))\r
+ (error nil))\r
+\r
+(autoload 'c-macro-expand "cmacexp"\r
+ "Display the result of expanding all C macros occurring in the region.\r
+The expansion is entirely correct because it uses the C preprocessor."\r
+ t)\r
+\r
+(defvar cperl-imenu--function-name-regexp-perl\r
+ (concat\r
+ "^\\("\r
+ "[ \t]*\\(sub\\|package\\)[ \t\n]+\\([a-zA-Z_0-9:']+\\)[ \t]*\\(([^()]*)[ \t]*\\)?"\r
+ "\\|"\r
+ "=head\\([12]\\)[ \t]+\\([^\n]+\\)$"\r
+ "\\)"))\r
+\r
+(defvar cperl-outline-regexp\r
+ (concat cperl-imenu--function-name-regexp-perl "\\|" "\\`"))\r
+\r
+(defvar cperl-mode-syntax-table nil\r
+ "Syntax table in use in CPerl mode buffers.")\r
+\r
+(defvar cperl-string-syntax-table nil\r
+ "Syntax table in use in CPerl mode string-like chunks.")\r
+\r
+(if cperl-mode-syntax-table\r
+ ()\r
+ (setq cperl-mode-syntax-table (make-syntax-table))\r
+ (modify-syntax-entry ?\\ "\\" cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?/ "." cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?* "." cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?+ "." cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?- "." cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?= "." cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?% "." cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?< "." cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?> "." cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?& "." cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?$ "\\" cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?\n ">" cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?# "<" cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?' "\"" cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?` "\"" cperl-mode-syntax-table)\r
+ (if cperl-under-as-char\r
+ (modify-syntax-entry ?_ "w" cperl-mode-syntax-table))\r
+ (modify-syntax-entry ?: "_" cperl-mode-syntax-table)\r
+ (modify-syntax-entry ?| "." cperl-mode-syntax-table)\r
+ (setq cperl-string-syntax-table (copy-syntax-table cperl-mode-syntax-table))\r
+ (modify-syntax-entry ?$ "." cperl-string-syntax-table)\r
+ (modify-syntax-entry ?# "." cperl-string-syntax-table)) ; (?# comment )\r
+\r
+\r
+\f\r
+;; provide an alias for working with emacs 19. the perl-mode that comes\r
+;; with it is really bad, and this lets us seamlessly replace it.\r
+;;;###autoload\r
+(fset 'perl-mode 'cperl-mode)\r
+(defvar cperl-faces-init nil)\r
+;; Fix for msb.el\r
+(defvar cperl-msb-fixed nil)\r
+(defvar font-lock-syntactic-keywords)\r
+(defvar perl-font-lock-keywords)\r
+(defvar perl-font-lock-keywords-1)\r
+(defvar perl-font-lock-keywords-2)\r
+(defvar outline-level)\r
+(if (fboundp 'defvaralias)\r
+ (let ((f 'defvaralias)) ; Some functions deduce stuff from the mode name...\r
+ (funcall f 'cperl-font-lock-keywords 'perl-font-lock-keywords)\r
+ (funcall f 'cperl-font-lock-keywords-1 'perl-font-lock-keywords-1)\r
+ (funcall f 'cperl-font-lock-keywords-2 'perl-font-lock-keywords-2)))\r
+\r
+(defvar cperl-use-major-mode 'perl-mode)\r
+\r
+;;;###autoload\r
+(defun cperl-mode ()\r
+ "Major mode for editing Perl code.\r
+Expression and list commands understand all C brackets.\r
+Tab indents for Perl code.\r
+Paragraphs are separated by blank lines only.\r
+Delete converts tabs to spaces as it moves back.\r
+\r
+Various characters in Perl almost always come in pairs: {}, (), [],\r
+sometimes <>. When the user types the first, she gets the second as\r
+well, with optional special formatting done on {}. (Disabled by\r
+default.) You can always quote (with \\[quoted-insert]) the left\r
+\"paren\" to avoid the expansion. The processing of < is special,\r
+since most the time you mean \"less\". CPerl mode tries to guess\r
+whether you want to type pair <>, and inserts is if it\r
+appropriate. You can set `cperl-electric-parens-string' to the string that\r
+contains the parenths from the above list you want to be electrical.\r
+Electricity of parenths is controlled by `cperl-electric-parens'.\r
+You may also set `cperl-electric-parens-mark' to have electric parens\r
+look for active mark and \"embrace\" a region if possible.'\r
+\r
+CPerl mode provides expansion of the Perl control constructs:\r
+\r
+ if, else, elsif, unless, while, until, continue, do,\r
+ for, foreach, formy and foreachmy.\r
+\r
+and POD directives (Disabled by default, see `cperl-electric-keywords'.)\r
+\r
+The user types the keyword immediately followed by a space, which\r
+causes the construct to be expanded, and the point is positioned where\r
+she is most likely to want to be. eg. when the user types a space\r
+following \"if\" the following appears in the buffer: if () { or if ()\r
+} { } and the cursor is between the parentheses. The user can then\r
+type some boolean expression within the parens. Having done that,\r
+typing \\[cperl-linefeed] places you - appropriately indented - on a\r
+new line between the braces (if you typed \\[cperl-linefeed] in a POD\r
+directive line, then appropriate number of new lines is inserted).\r
+\r
+If CPerl decides that you want to insert \"English\" style construct like\r
+\r
+ bite if angry;\r
+\r
+it will not do any expansion. See also help on variable\r
+`cperl-extra-newline-before-brace'. (Note that one can switch the\r
+help message on expansion by setting `cperl-message-electric-keyword'\r
+to nil.)\r
+\r
+\\[cperl-linefeed] is a convenience replacement for typing carriage\r
+return. It places you in the next line with proper indentation, or if\r
+you type it inside the inline block of control construct, like\r
+\r
+ foreach (@lines) {print; print}\r
+\r
+and you are on a boundary of a statement inside braces, it will\r
+transform the construct into a multiline and will place you into an\r
+appropriately indented blank line. If you need a usual\r
+`newline-and-indent' behaviour, it is on \\[newline-and-indent],\r
+see documentation on `cperl-electric-linefeed'.\r
+\r
+Use \\[cperl-invert-if-unless] to change a construction of the form\r
+\r
+ if (A) { B }\r
+\r
+into\r
+\r
+ B if A;\r
+\r
+\\{cperl-mode-map}\r
+\r
+Setting the variable `cperl-font-lock' to t switches on font-lock-mode\r
+\(even with older Emacsen), `cperl-electric-lbrace-space' to t switches\r
+on electric space between $ and {, `cperl-electric-parens-string' is\r
+the string that contains parentheses that should be electric in CPerl\r
+\(see also `cperl-electric-parens-mark' and `cperl-electric-parens'),\r
+setting `cperl-electric-keywords' enables electric expansion of\r
+control structures in CPerl. `cperl-electric-linefeed' governs which\r
+one of two linefeed behavior is preferable. You can enable all these\r
+options simultaneously (recommended mode of use) by setting\r
+`cperl-hairy' to t. In this case you can switch separate options off\r
+by setting them to `null'. Note that one may undo the extra\r
+whitespace inserted by semis and braces in `auto-newline'-mode by\r
+consequent \\[cperl-electric-backspace].\r
+\r
+If your site has perl5 documentation in info format, you can use commands\r
+\\[cperl-info-on-current-command] and \\[cperl-info-on-command] to access it.\r
+These keys run commands `cperl-info-on-current-command' and\r
+`cperl-info-on-command', which one is which is controlled by variable\r
+`cperl-info-on-command-no-prompt' and `cperl-clobber-lisp-bindings'\r
+\(in turn affected by `cperl-hairy').\r
+\r
+Even if you have no info-format documentation, short one-liner-style\r
+help is available on \\[cperl-get-help], and one can run perldoc or\r
+man via menu.\r
+\r
+It is possible to show this help automatically after some idle time.\r
+This is regulated by variable `cperl-lazy-help-time'. Default with\r
+`cperl-hairy' (if the value of `cperl-lazy-help-time' is nil) is 5\r
+secs idle time . It is also possible to switch this on/off from the\r
+menu, or via \\[cperl-toggle-autohelp]. Requires `run-with-idle-timer'.\r
+\r
+Use \\[cperl-lineup] to vertically lineup some construction - put the\r
+beginning of the region at the start of construction, and make region\r
+span the needed amount of lines.\r
+\r
+Variables `cperl-pod-here-scan', `cperl-pod-here-fontify',\r
+`cperl-pod-face', `cperl-pod-head-face' control processing of POD and\r
+here-docs sections. With capable Emaxen results of scan are used\r
+for indentation too, otherwise they are used for highlighting only.\r
+\r
+Variables controlling indentation style:\r
+ `cperl-tab-always-indent'\r
+ Non-nil means TAB in CPerl mode should always reindent the current line,\r
+ regardless of where in the line point is when the TAB command is used.\r
+ `cperl-indent-left-aligned-comments'\r
+ Non-nil means that the comment starting in leftmost column should indent.\r
+ `cperl-auto-newline'\r
+ Non-nil means automatically newline before and after braces,\r
+ and after colons and semicolons, inserted in Perl code. The following\r
+ \\[cperl-electric-backspace] will remove the inserted whitespace.\r
+ Insertion after colons requires both this variable and\r
+ `cperl-auto-newline-after-colon' set.\r
+ `cperl-auto-newline-after-colon'\r
+ Non-nil means automatically newline even after colons.\r
+ Subject to `cperl-auto-newline' setting.\r
+ `cperl-indent-level'\r
+ Indentation of Perl statements within surrounding block.\r
+ The surrounding block's indentation is the indentation\r
+ of the line on which the open-brace appears.\r
+ `cperl-continued-statement-offset'\r
+ Extra indentation given to a substatement, such as the\r
+ then-clause of an if, or body of a while, or just a statement continuation.\r
+ `cperl-continued-brace-offset'\r
+ Extra indentation given to a brace that starts a substatement.\r
+ This is in addition to `cperl-continued-statement-offset'.\r
+ `cperl-brace-offset'\r
+ Extra indentation for line if it starts with an open brace.\r
+ `cperl-brace-imaginary-offset'\r
+ An open brace following other text is treated as if it the line started\r
+ this far to the right of the actual line indentation.\r
+ `cperl-label-offset'\r
+ Extra indentation for line that is a label.\r
+ `cperl-min-label-indent'\r
+ Minimal indentation for line that is a label.\r
+\r
+Settings for K&R and BSD indentation styles are\r
+ `cperl-indent-level' 5 8\r
+ `cperl-continued-statement-offset' 5 8\r
+ `cperl-brace-offset' -5 -8\r
+ `cperl-label-offset' -5 -8\r
+\r
+CPerl knows several indentation styles, and may bulk set the\r
+corresponding variables. Use \\[cperl-set-style] to do this. Use\r
+\\[cperl-set-style-back] to restore the memorized preexisting values\r
+\(both available from menu).\r
+\r
+If `cperl-indent-level' is 0, the statement after opening brace in\r
+column 0 is indented on\r
+`cperl-brace-offset'+`cperl-continued-statement-offset'.\r
+\r
+Turning on CPerl mode calls the hooks in the variable `cperl-mode-hook'\r
+with no args.\r
+\r
+DO NOT FORGET to read micro-docs (available from `Perl' menu)\r
+or as help on variables `cperl-tips', `cperl-problems',\r
+`cperl-non-problems', `cperl-praise', `cperl-speed'."\r
+ (interactive)\r
+ (kill-all-local-variables)\r
+ (use-local-map cperl-mode-map)\r
+ (if (cperl-val 'cperl-electric-linefeed)\r
+ (progn\r
+ (local-set-key "\C-J" 'cperl-linefeed)\r
+ (local-set-key "\C-C\C-J" 'newline-and-indent)))\r
+ (if (and\r
+ (cperl-val 'cperl-clobber-lisp-bindings)\r
+ (cperl-val 'cperl-info-on-command-no-prompt))\r
+ (progn\r
+ ;; don't clobber the backspace binding:\r
+ (cperl-define-key "\C-hf" 'cperl-info-on-current-command [(control h) f])\r
+ (cperl-define-key "\C-c\C-hf" 'cperl-info-on-command\r
+ [(control c) (control h) f])))\r
+ (setq major-mode cperl-use-major-mode)\r
+ (setq mode-name "CPerl")\r
+ (if (not cperl-mode-abbrev-table)\r
+ (let ((prev-a-c abbrevs-changed))\r
+ (define-abbrev-table 'cperl-mode-abbrev-table '(\r
+ ("if" "if" cperl-electric-keyword 0)\r
+ ("elsif" "elsif" cperl-electric-keyword 0)\r
+ ("while" "while" cperl-electric-keyword 0)\r
+ ("until" "until" cperl-electric-keyword 0)\r
+ ("unless" "unless" cperl-electric-keyword 0)\r
+ ("else" "else" cperl-electric-else 0)\r
+ ("continue" "continue" cperl-electric-else 0)\r
+ ("for" "for" cperl-electric-keyword 0)\r
+ ("foreach" "foreach" cperl-electric-keyword 0)\r
+ ("formy" "formy" cperl-electric-keyword 0)\r
+ ("foreachmy" "foreachmy" cperl-electric-keyword 0)\r
+ ("do" "do" cperl-electric-keyword 0)\r
+ ("=pod" "=pod" cperl-electric-pod 0)\r
+ ("=over" "=over" cperl-electric-pod 0)\r
+ ("=head1" "=head1" cperl-electric-pod 0)\r
+ ("=head2" "=head2" cperl-electric-pod 0)\r
+ ("pod" "pod" cperl-electric-pod 0)\r
+ ("over" "over" cperl-electric-pod 0)\r
+ ("head1" "head1" cperl-electric-pod 0)\r
+ ("head2" "head2" cperl-electric-pod 0)))\r
+ (setq abbrevs-changed prev-a-c)))\r
+ (setq local-abbrev-table cperl-mode-abbrev-table)\r
+ (abbrev-mode (if (cperl-val 'cperl-electric-keywords) 1 0))\r
+ (set-syntax-table cperl-mode-syntax-table)\r
+ (make-local-variable 'outline-regexp)\r
+ ;; (setq outline-regexp imenu-example--function-name-regexp-perl)\r
+ (setq outline-regexp cperl-outline-regexp)\r
+ (make-local-variable 'outline-level)\r
+ (setq outline-level 'cperl-outline-level)\r
+ (make-local-variable 'paragraph-start)\r
+ (setq paragraph-start (concat "^$\\|" page-delimiter))\r
+ (make-local-variable 'paragraph-separate)\r
+ (setq paragraph-separate paragraph-start)\r
+ (make-local-variable 'paragraph-ignore-fill-prefix)\r
+ (setq paragraph-ignore-fill-prefix t)\r
+ (make-local-variable 'indent-line-function)\r
+ (setq indent-line-function 'cperl-indent-line)\r
+ (make-local-variable 'require-final-newline)\r
+ (setq require-final-newline t)\r
+ (make-local-variable 'comment-start)\r
+ (setq comment-start "# ")\r
+ (make-local-variable 'comment-end)\r
+ (setq comment-end "")\r
+ (make-local-variable 'comment-column)\r
+ (setq comment-column cperl-comment-column)\r
+ (make-local-variable 'comment-start-skip)\r
+ (setq comment-start-skip "#+ *")\r
+ (make-local-variable 'defun-prompt-regexp)\r
+ (setq defun-prompt-regexp "^[ \t]*sub[ \t]+\\([^ \t\n{(;]+\\)\\([ \t]*([^()]*)[ \t]*\\)?[ \t]*")\r
+ (make-local-variable 'comment-indent-function)\r
+ (setq comment-indent-function 'cperl-comment-indent)\r
+ (make-local-variable 'parse-sexp-ignore-comments)\r
+ (setq parse-sexp-ignore-comments t)\r
+ (make-local-variable 'indent-region-function)\r
+ (setq indent-region-function 'cperl-indent-region)\r
+ ;;(setq auto-fill-function 'cperl-do-auto-fill) ; Need to switch on and off!\r
+ (make-local-variable 'imenu-create-index-function)\r
+ (setq imenu-create-index-function\r
+ (function cperl-imenu--create-perl-index))\r
+ (make-local-variable 'imenu-sort-function)\r
+ (setq imenu-sort-function nil)\r
+ (make-local-variable 'vc-header-alist)\r
+ (set 'vc-header-alist cperl-vc-header-alist) ; Avoid warning\r
+ (make-local-variable 'font-lock-defaults)\r
+ (setq font-lock-defaults\r
+ (cond\r
+ ((string< emacs-version "19.30")\r
+ '(perl-font-lock-keywords-2))\r
+ ((string< emacs-version "19.33") ; Which one to use?\r
+ '((perl-font-lock-keywords\r
+ perl-font-lock-keywords-1\r
+ perl-font-lock-keywords-2)))\r
+ (t\r
+ '((cperl-load-font-lock-keywords\r
+ cperl-load-font-lock-keywords-1\r
+ cperl-load-font-lock-keywords-2)))))\r
+ (make-local-variable 'cperl-syntax-state)\r
+ (if cperl-use-syntax-table-text-property\r
+ (progn\r
+ (make-local-variable 'parse-sexp-lookup-properties)\r
+ ;; Do not introduce variable if not needed, we check it!\r
+ (set 'parse-sexp-lookup-properties t)\r
+ ;; Fix broken font-lock:\r
+ (or (boundp 'font-lock-unfontify-region-function)\r
+ (set 'font-lock-unfontify-region-function\r
+ 'font-lock-default-unfontify-region))\r
+ (make-local-variable 'font-lock-unfontify-region-function)\r
+ (set 'font-lock-unfontify-region-function ; not present with old Emacs\r
+ 'cperl-font-lock-unfontify-region-function)\r
+ (make-local-variable 'cperl-syntax-done-to)\r
+ ;; Another bug: unless font-lock-syntactic-keywords, font-lock\r
+ ;; ignores syntax-table text-property. (t) is a hack\r
+ ;; to make font-lock think that font-lock-syntactic-keywords\r
+ ;; are defined\r
+ (make-local-variable 'font-lock-syntactic-keywords)\r
+ (setq font-lock-syntactic-keywords\r
+ (if cperl-syntaxify-by-font-lock\r
+ '(t (cperl-fontify-syntaxically))\r
+ '(t)))))\r
+ (make-local-variable 'cperl-old-style)\r
+ (if (boundp 'normal-auto-fill-function) ; 19.33 and later\r
+ (set (make-local-variable 'normal-auto-fill-function)\r
+ 'cperl-do-auto-fill) ; RMS has it as #'cperl-do-auto-fill ???\r
+ (or (fboundp 'cperl-old-auto-fill-mode)\r
+ (progn\r
+ (fset 'cperl-old-auto-fill-mode (symbol-function 'auto-fill-mode))\r
+ (defun auto-fill-mode (&optional arg)\r
+ (interactive "P")\r
+ (eval '(cperl-old-auto-fill-mode arg)) ; Avoid a warning\r
+ (and auto-fill-function (memq major-mode '(perl-mode cperl-mode))\r
+ (setq auto-fill-function 'cperl-do-auto-fill))))))\r
+ (if (cperl-enable-font-lock)\r
+ (if (cperl-val 'cperl-font-lock)\r
+ (progn (or cperl-faces-init (cperl-init-faces))\r
+ (font-lock-mode 1))))\r
+ (and (boundp 'msb-menu-cond)\r
+ (not cperl-msb-fixed)\r
+ (cperl-msb-fix))\r
+ (if (featurep 'easymenu)\r
+ (easy-menu-add cperl-menu)) ; A NOP in RMS Emacs.\r
+ (run-hooks 'cperl-mode-hook)\r
+ ;; After hooks since fontification will break this\r
+ (if cperl-pod-here-scan\r
+ (or cperl-syntaxify-by-font-lock\r
+ (progn (or cperl-faces-init (cperl-init-faces-weak))\r
+ (cperl-find-pods-heres)))))\r
+\f\r
+;; Fix for perldb - make default reasonable\r
+(defun cperl-db ()\r
+ (interactive)\r
+ (require 'gud)\r
+ (perldb (read-from-minibuffer "Run perldb (like this): "\r
+ (if (consp gud-perldb-history)\r
+ (car gud-perldb-history)\r
+ (concat "perl " ;;(file-name-nondirectory\r
+ ;; I have problems\r
+ ;; in OS/2\r
+ ;; otherwise\r
+ (buffer-file-name)))\r
+ nil nil\r
+ '(gud-perldb-history . 1))))\r
+\f\r
+(defun cperl-msb-fix ()\r
+ ;; Adds perl files to msb menu, supposes that msb is already loaded\r
+ (setq cperl-msb-fixed t)\r
+ (let* ((l (length msb-menu-cond))\r
+ (last (nth (1- l) msb-menu-cond))\r
+ (precdr (nthcdr (- l 2) msb-menu-cond)) ; cdr of this is last\r
+ (handle (1- (nth 1 last))))\r
+ (setcdr precdr (list\r
+ (list\r
+ '(memq major-mode '(cperl-mode perl-mode))\r
+ handle\r
+ "Perl Files (%d)")\r
+ last))))\r
+\f\r
+;; This is used by indent-for-comment\r
+;; to decide how much to indent a comment in CPerl code\r
+;; based on its context. Do fallback if comment is found wrong.\r
+\r
+(defvar cperl-wrong-comment)\r
+(defvar cperl-st-cfence '(14)) ; Comment-fence\r
+(defvar cperl-st-sfence '(15)) ; String-fence\r
+(defvar cperl-st-punct '(1))\r
+(defvar cperl-st-word '(2))\r
+(defvar cperl-st-bra '(4 . ?\>))\r
+(defvar cperl-st-ket '(5 . ?\<))\r
+\r
+\r
+(defun cperl-comment-indent ()\r
+ (let ((p (point)) (c (current-column)) was phony)\r
+ (if (looking-at "^#") 0 ; Existing comment at bol stays there.\r
+ ;; Wrong comment found\r
+ (save-excursion\r
+ (setq was (cperl-to-comment-or-eol)\r
+ phony (eq (get-text-property (point) 'syntax-table)\r
+ cperl-st-cfence))\r
+ (if phony\r
+ (progn\r
+ (re-search-forward "#\\|$") ; Hmm, what about embedded #?\r
+ (if (eq (preceding-char) ?\#)\r
+ (forward-char -1))\r
+ (setq was nil)))\r
+ (if (= (point) p)\r
+ (progn\r
+ (skip-chars-backward " \t")\r
+ (max (1+ (current-column)) ; Else indent at comment column\r
+ comment-column))\r
+ (if was nil\r
+ (insert comment-start)\r
+ (backward-char (length comment-start)))\r
+ (setq cperl-wrong-comment t)\r
+ (indent-to comment-column 1) ; Indent minimum 1\r
+ c))))) ; except leave at least one space.\r
+\r
+;;;(defun cperl-comment-indent-fallback ()\r
+;;; "Is called if the standard comment-search procedure fails.\r
+;;;Point is at start of real comment."\r
+;;; (let ((c (current-column)) target cnt prevc)\r
+;;; (if (= c comment-column) nil\r
+;;; (setq cnt (skip-chars-backward "[ \t]"))\r
+;;; (setq target (max (1+ (setq prevc\r
+;;; (current-column))) ; Else indent at comment column\r
+;;; comment-column))\r
+;;; (if (= c comment-column) nil\r
+;;; (delete-backward-char cnt)\r
+;;; (while (< prevc target)\r
+;;; (insert "\t")\r
+;;; (setq prevc (current-column)))\r
+;;; (if (> prevc target) (progn (delete-char -1) (setq prevc (current-column))))\r
+;;; (while (< prevc target)\r
+;;; (insert " ")\r
+;;; (setq prevc (current-column)))))))\r
+\r
+(defun cperl-indent-for-comment ()\r
+ "Substitute for `indent-for-comment' in CPerl."\r
+ (interactive)\r
+ (let (cperl-wrong-comment)\r
+ (indent-for-comment)\r
+ (if cperl-wrong-comment\r
+ (progn (cperl-to-comment-or-eol)\r
+ (forward-char (length comment-start))))))\r
+\r
+(defun cperl-comment-region (b e arg)\r
+ "Comment or uncomment each line in the region in CPerl mode.\r
+See `comment-region'."\r
+ (interactive "r\np")\r
+ (let ((comment-start "#"))\r
+ (comment-region b e arg)))\r
+\r
+(defun cperl-uncomment-region (b e arg)\r
+ "Uncomment or comment each line in the region in CPerl mode.\r
+See `comment-region'."\r
+ (interactive "r\np")\r
+ (let ((comment-start "#"))\r
+ (comment-region b e (- arg))))\r
+\r
+(defvar cperl-brace-recursing nil)\r
+\r
+(defun cperl-electric-brace (arg &optional only-before)\r
+ "Insert character and correct line's indentation.\r
+If ONLY-BEFORE and `cperl-auto-newline', will insert newline before the\r
+place (even in empty line), but not after. If after \")\" and the inserted\r
+char is \"{\", insert extra newline before only if\r
+`cperl-extra-newline-before-brace'."\r
+ (interactive "P")\r
+ (let (insertpos\r
+ (other-end (if (and cperl-electric-parens-mark\r
+ (cperl-mark-active)\r
+ (< (mark) (point)))\r
+ (mark)\r
+ nil)))\r
+ (if (and other-end\r
+ (not cperl-brace-recursing)\r
+ (cperl-val 'cperl-electric-parens)\r
+ (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point)))\r
+ ;; Need to insert a matching pair\r
+ (progn\r
+ (save-excursion\r
+ (setq insertpos (point-marker))\r
+ (goto-char other-end)\r
+ (setq last-command-char ?\{)\r
+ (cperl-electric-lbrace arg insertpos))\r
+ (forward-char 1))\r
+ ;; Check whether we close something "usual" with `}'\r
+ (if (and (eq last-command-char ?\})\r
+ (not\r
+ (condition-case nil\r
+ (save-excursion\r
+ (up-list (- (prefix-numeric-value arg)))\r
+ ;;(cperl-after-block-p (point-min))\r
+ (or (cperl-after-expr-p nil "{;)")\r
+ ;; after sub, else, continue\r
+ (cperl-after-block-p nil 'pre)))\r
+ (error nil))))\r
+ ;; Just insert the guy\r
+ (self-insert-command (prefix-numeric-value arg))\r
+ (if (and (not arg) ; No args, end (of empty line or auto)\r
+ (eolp)\r
+ (or (and (null only-before)\r
+ (save-excursion\r
+ (skip-chars-backward " \t")\r
+ (bolp)))\r
+ (and (eq last-command-char ?\{) ; Do not insert newline\r
+ ;; if after ")" and `cperl-extra-newline-before-brace'\r
+ ;; is nil, do not insert extra newline.\r
+ (not cperl-extra-newline-before-brace)\r
+ (save-excursion\r
+ (skip-chars-backward " \t")\r
+ (eq (preceding-char) ?\))))\r
+ (if cperl-auto-newline\r
+ (progn (cperl-indent-line) (newline) t) nil)))\r
+ (progn\r
+ (self-insert-command (prefix-numeric-value arg))\r
+ (cperl-indent-line)\r
+ (if cperl-auto-newline\r
+ (setq insertpos (1- (point))))\r
+ (if (and cperl-auto-newline (null only-before))\r
+ (progn\r
+ (newline)\r
+ (cperl-indent-line)))\r
+ (save-excursion\r
+ (if insertpos (progn (goto-char insertpos)\r
+ (search-forward (make-string\r
+ 1 last-command-char))\r
+ (setq insertpos (1- (point)))))\r
+ (delete-char -1))))\r
+ (if insertpos\r
+ (save-excursion\r
+ (goto-char insertpos)\r
+ (self-insert-command (prefix-numeric-value arg)))\r
+ (self-insert-command (prefix-numeric-value arg)))))))\r
+\r
+(defun cperl-electric-lbrace (arg &optional end)\r
+ "Insert character, correct line's indentation, correct quoting by space."\r
+ (interactive "P")\r
+ (let ((cperl-brace-recursing t)\r
+ (cperl-auto-newline cperl-auto-newline)\r
+ (other-end (or end\r
+ (if (and cperl-electric-parens-mark\r
+ (cperl-mark-active)\r
+ (> (mark) (point)))\r
+ (save-excursion\r
+ (goto-char (mark))\r
+ (point-marker))\r
+ nil)))\r
+ pos after)\r
+ (and (cperl-val 'cperl-electric-lbrace-space)\r
+ (eq (preceding-char) ?$)\r
+ (save-excursion\r
+ (skip-chars-backward "$")\r
+ (looking-at "\\(\\$\\$\\)*\\$\\([^\\$]\\|$\\)"))\r
+ (insert ?\ ))\r
+ ;; Check whether we are in comment\r
+ (if (and\r
+ (save-excursion\r
+ (beginning-of-line)\r
+ (not (looking-at "[ \t]*#")))\r
+ (cperl-after-expr-p nil "{;)"))\r
+ nil\r
+ (setq cperl-auto-newline nil))\r
+ (cperl-electric-brace arg)\r
+ (and (cperl-val 'cperl-electric-parens)\r
+ (eq last-command-char ?{)\r
+ (memq last-command-char\r
+ (append cperl-electric-parens-string nil))\r
+ (or (if other-end (goto-char (marker-position other-end)))\r
+ t)\r
+ (setq last-command-char ?} pos (point))\r
+ (progn (cperl-electric-brace arg t)\r
+ (goto-char pos)))))\r
+\r
+(defun cperl-electric-paren (arg)\r
+ "Insert an opening parenthesis or a matching pair of parentheses.\r
+See `cperl-electric-parens'."\r
+ (interactive "P")\r
+ (let ((beg (save-excursion (beginning-of-line) (point)))\r
+ (other-end (if (and cperl-electric-parens-mark\r
+ (cperl-mark-active)\r
+ (> (mark) (point)))\r
+ (save-excursion\r
+ (goto-char (mark))\r
+ (point-marker))\r
+ nil)))\r
+ (if (and (cperl-val 'cperl-electric-parens)\r
+ (memq last-command-char\r
+ (append cperl-electric-parens-string nil))\r
+ (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point))\r
+ ;;(not (save-excursion (search-backward "#" beg t)))\r
+ (if (eq last-command-char ?<)\r
+ (progn\r
+ (and abbrev-mode ; later it is too late, may be after `for'\r
+ (expand-abbrev))\r
+ (cperl-after-expr-p nil "{;(,:="))\r
+ 1))\r
+ (progn\r
+ (self-insert-command (prefix-numeric-value arg))\r
+ (if other-end (goto-char (marker-position other-end)))\r
+ (insert (make-string\r
+ (prefix-numeric-value arg)\r
+ (cdr (assoc last-command-char '((?{ .?})\r
+ (?[ . ?])\r
+ (?( . ?))\r
+ (?< . ?>))))))\r
+ (forward-char (- (prefix-numeric-value arg))))\r
+ (self-insert-command (prefix-numeric-value arg)))))\r
+\r
+(defun cperl-electric-rparen (arg)\r
+ "Insert a matching pair of parentheses if marking is active.\r
+If not, or if we are not at the end of marking range, would self-insert.\r
+Affected by `cperl-electric-parens'."\r
+ (interactive "P")\r
+ (let ((beg (save-excursion (beginning-of-line) (point)))\r
+ (other-end (if (and cperl-electric-parens-mark\r
+ (cperl-val 'cperl-electric-parens)\r
+ (memq last-command-char\r
+ (append cperl-electric-parens-string nil))\r
+ (cperl-mark-active)\r
+ (< (mark) (point)))\r
+ (mark)\r
+ nil))\r
+ p)\r
+ (if (and other-end\r
+ (cperl-val 'cperl-electric-parens)\r
+ (memq last-command-char '( ?\) ?\] ?\} ?\> ))\r
+ (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point))\r
+ ;;(not (save-excursion (search-backward "#" beg t)))\r
+ )\r
+ (progn\r
+ (self-insert-command (prefix-numeric-value arg))\r
+ (setq p (point))\r
+ (if other-end (goto-char other-end))\r
+ (insert (make-string\r
+ (prefix-numeric-value arg)\r
+ (cdr (assoc last-command-char '((?\} . ?\{)\r
+ (?\] . ?\[)\r
+ (?\) . ?\()\r
+ (?\> . ?\<))))))\r
+ (goto-char (1+ p)))\r
+ (self-insert-command (prefix-numeric-value arg)))))\r
+\r
+(defun cperl-electric-keyword ()\r
+ "Insert a construction appropriate after a keyword.\r
+Help message may be switched off by setting `cperl-message-electric-keyword'\r
+to nil."\r
+ (let ((beg (save-excursion (beginning-of-line) (point)))\r
+ (dollar (and (eq last-command-char ?$)\r
+ (eq this-command 'self-insert-command)))\r
+ (delete (and (memq last-command-char '(?\ ?\n ?\t ?\f))\r
+ (memq this-command '(self-insert-command newline))))\r
+ my do)\r
+ (and (save-excursion\r
+ (condition-case nil\r
+ (progn\r
+ (backward-sexp 1)\r
+ (setq do (looking-at "do\\>")))\r
+ (error nil))\r
+ (cperl-after-expr-p nil "{;:"))\r
+ (save-excursion\r
+ (not\r
+ (re-search-backward\r
+ "[#\"'`]\\|\\<q\\(\\|[wqxr]\\)\\>"\r
+ beg t)))\r
+ (save-excursion (or (not (re-search-backward "^=" nil t))\r
+ (or\r
+ (looking-at "=cut")\r
+ (and cperl-use-syntax-table-text-property\r
+ (not (eq (get-text-property (point)\r
+ 'syntax-type)\r
+ 'pod))))))\r
+ (save-excursion (forward-sexp -1) \r
+ (not (memq (following-char) (append "$@%&*" nil))))\r
+ (progn\r
+ (and (eq (preceding-char) ?y)\r
+ (progn ; "foreachmy"\r
+ (forward-char -2)\r
+ (insert " ")\r
+ (forward-char 2)\r
+ (setq my t dollar t\r
+ delete\r
+ (memq this-command '(self-insert-command newline)))))\r
+ (and dollar (insert " $"))\r
+ (cperl-indent-line)\r
+ ;;(insert " () {\n}")\r
+ (cond\r
+ (cperl-extra-newline-before-brace\r
+ (insert (if do "\n" " ()\n"))\r
+ (insert "{")\r
+ (cperl-indent-line)\r
+ (insert "\n")\r
+ (cperl-indent-line)\r
+ (insert "\n}")\r
+ (and do (insert " while ();")))\r
+ (t\r
+ (insert (if do " {\n} while ();" " () {\n}"))))\r
+ (or (looking-at "[ \t]\\|$") (insert " "))\r
+ (cperl-indent-line)\r
+ (if dollar (progn (search-backward "$")\r
+ (if my\r
+ (forward-char 1)\r
+ (delete-char 1)))\r
+ (search-backward ")")\r
+ (if (eq last-command-char ?\()\r
+ (progn ; Avoid "if (())"\r
+ (delete-backward-char 1)\r
+ (delete-backward-char -1))))\r
+ (if delete\r
+ (cperl-putback-char cperl-del-back-ch))\r
+ (if cperl-message-electric-keyword\r
+ (message "Precede char by C-q to avoid expansion"))))))\r
+\r
+(defun cperl-ensure-newlines (n &optional pos)\r
+ "Make sure there are N newlines after the point."\r
+ (or pos (setq pos (point)))\r
+ (if (looking-at "\n")\r
+ (forward-char 1)\r
+ (insert "\n"))\r
+ (if (> n 1)\r
+ (cperl-ensure-newlines (1- n) pos)\r
+ (goto-char pos)))\r
+\r
+(defun cperl-electric-pod ()\r
+ "Insert a POD chunk appropriate after a =POD directive."\r
+ (let ((delete (and (memq last-command-char '(?\ ?\n ?\t ?\f))\r
+ (memq this-command '(self-insert-command newline))))\r
+ head1 notlast name p really-delete over)\r
+ (and (save-excursion\r
+ (forward-word -1)\r
+ (and\r
+ (eq (preceding-char) ?=)\r
+ (progn\r
+ (setq head1 (looking-at "head1\\>[ \t]*$"))\r
+ (setq over (and (looking-at "over\\>[ \t]*$")\r
+ (not (looking-at "over[ \t]*\n\n\n*=item\\>"))))\r
+ (forward-char -1)\r
+ (bolp))\r
+ (or\r
+ (get-text-property (point) 'in-pod)\r
+ (cperl-after-expr-p nil "{;:")\r
+ (and (re-search-backward\r
+ ;; "\\(\\`\n?\\|\n\n\\)=\\sw+"\r
+ "\\(\\`\n?\\|^\n\\)=\\sw+"\r
+ (point-min) t)\r
+ (not (or\r
+ (looking-at "=cut")\r
+ (and cperl-use-syntax-table-text-property\r
+ (not (eq (get-text-property (point) 'syntax-type)\r
+ 'pod)))))))))\r
+ (progn\r
+ (save-excursion\r
+ (setq notlast (re-search-forward "^\n=" nil t)))\r
+ (or notlast\r
+ (progn\r
+ (insert "\n\n=cut")\r
+ (cperl-ensure-newlines 2)\r
+ (forward-word -2)\r
+ (if (and head1\r
+ (not\r
+ (save-excursion\r
+ (forward-char -1)\r
+ (re-search-backward "\\(\\`\n?\\|\n\n\\)=head1\\>"\r
+ nil t)))) ; Only one\r
+ (progn\r
+ (forward-word 1)\r
+ (setq name (file-name-sans-extension\r
+ (file-name-nondirectory (buffer-file-name)))\r
+ p (point))\r
+ (insert " NAME\n\n" name\r
+ " - \n\n=head1 SYNOPSIS\n\n\n\n"\r
+ "=head1 DESCRIPTION")\r
+ (cperl-ensure-newlines 4)\r
+ (goto-char p)\r
+ (forward-word 2)\r
+ (end-of-line)\r
+ (setq really-delete t))\r
+ (forward-word 1))))\r
+ (if over\r
+ (progn\r
+ (setq p (point))\r
+ (insert "\n\n=item \n\n\n\n"\r
+ "=back")\r
+ (cperl-ensure-newlines 2)\r
+ (goto-char p)\r
+ (forward-word 1)\r
+ (end-of-line)\r
+ (setq really-delete t)))\r
+ (if (and delete really-delete)\r
+ (cperl-putback-char cperl-del-back-ch))))))\r
+\r
+(defun cperl-electric-else ()\r
+ "Insert a construction appropriate after a keyword.\r
+Help message may be switched off by setting `cperl-message-electric-keyword'\r
+to nil."\r
+ (let ((beg (save-excursion (beginning-of-line) (point))))\r
+ (and (save-excursion\r
+ (backward-sexp 1)\r
+ (cperl-after-expr-p nil "{;:"))\r
+ (save-excursion\r
+ (not\r
+ (re-search-backward\r
+ "[#\"'`]\\|\\<q\\(\\|[wqxr]\\)\\>"\r
+ beg t)))\r
+ (save-excursion (or (not (re-search-backward "^=" nil t))\r
+ (looking-at "=cut")\r
+ (and cperl-use-syntax-table-text-property\r
+ (not (eq (get-text-property (point)\r
+ 'syntax-type)\r
+ 'pod)))))\r
+ (progn\r
+ (cperl-indent-line)\r
+ ;;(insert " {\n\n}")\r
+ (cond\r
+ (cperl-extra-newline-before-brace\r
+ (insert "\n")\r
+ (insert "{")\r
+ (cperl-indent-line)\r
+ (insert "\n\n}"))\r
+ (t\r
+ (insert " {\n\n}")))\r
+ (or (looking-at "[ \t]\\|$") (insert " "))\r
+ (cperl-indent-line)\r
+ (forward-line -1)\r
+ (cperl-indent-line)\r
+ (cperl-putback-char cperl-del-back-ch)\r
+ (setq this-command 'cperl-electric-else)\r
+ (if cperl-message-electric-keyword\r
+ (message "Precede char by C-q to avoid expansion"))))))\r
+\r
+(defun cperl-linefeed ()\r
+ "Go to end of line, open a new line and indent appropriately.\r
+If in POD, insert appropriate lines."\r
+ (interactive)\r
+ (let ((beg (save-excursion (beginning-of-line) (point)))\r
+ (end (save-excursion (end-of-line) (point)))\r
+ (pos (point)) start over cut res)\r
+ (if (and ; Check if we need to split:\r
+ ; i.e., on a boundary and inside "{...}"\r
+ (save-excursion (cperl-to-comment-or-eol)\r
+ (>= (point) pos)) ; Not in a comment\r
+ (or (save-excursion\r
+ (skip-chars-backward " \t" beg)\r
+ (forward-char -1)\r
+ (looking-at "[;{]")) ; After { or ; + spaces\r
+ (looking-at "[ \t]*}") ; Before }\r
+ (re-search-forward "\\=[ \t]*;" end t)) ; Before spaces + ;\r
+ (save-excursion\r
+ (and\r
+ (eq (car (parse-partial-sexp pos end -1)) -1)\r
+ ; Leave the level of parens\r
+ (looking-at "[,; \t]*\\($\\|#\\)") ; Comma to allow anon subr\r
+ ; Are at end\r
+ (cperl-after-block-p (point-min))\r
+ (progn\r
+ (backward-sexp 1)\r
+ (setq start (point-marker))\r
+ (<= start pos))))) ; Redundant? Are after the\r
+ ; start of parens group.\r
+ (progn\r
+ (skip-chars-backward " \t")\r
+ (or (memq (preceding-char) (append ";{" nil))\r
+ (insert ";"))\r
+ (insert "\n")\r
+ (forward-line -1)\r
+ (cperl-indent-line)\r
+ (goto-char start)\r
+ (or (looking-at "{[ \t]*$") ; If there is a statement\r
+ ; before, move it to separate line\r
+ (progn\r
+ (forward-char 1)\r
+ (insert "\n")\r
+ (cperl-indent-line)))\r
+ (forward-line 1) ; We are on the target line\r
+ (cperl-indent-line)\r
+ (beginning-of-line)\r
+ (or (looking-at "[ \t]*}[,; \t]*$") ; If there is a statement\r
+ ; after, move it to separate line\r
+ (progn\r
+ (end-of-line)\r
+ (search-backward "}" beg)\r
+ (skip-chars-backward " \t")\r
+ (or (memq (preceding-char) (append ";{" nil))\r
+ (insert ";"))\r
+ (insert "\n")\r
+ (cperl-indent-line)\r
+ (forward-line -1)))\r
+ (forward-line -1) ; We are on the line before target\r
+ (end-of-line)\r
+ (newline-and-indent))\r
+ (end-of-line) ; else - no splitting\r
+ (cond\r
+ ((and (looking-at "\n[ \t]*{$")\r
+ (save-excursion\r
+ (skip-chars-backward " \t")\r
+ (eq (preceding-char) ?\)))) ; Probably if () {} group\r
+ ; with an extra newline.\r
+ (forward-line 2)\r
+ (cperl-indent-line))\r
+ ((save-excursion ; In POD header\r
+ (forward-paragraph -1)\r
+ ;; (re-search-backward "\\(\\`\n?\\|\n\n\\)=head1\\b")\r
+ ;; We are after \n now, so look for the rest\r
+ (if (looking-at "\\(\\`\n?\\|\n\\)=\\sw+")\r
+ (progn\r
+ (setq cut (looking-at "\\(\\`\n?\\|\n\\)=cut\\>"))\r
+ (setq over (looking-at "\\(\\`\n?\\|\n\\)=over\\>"))\r
+ t)))\r
+ (if (and over\r
+ (progn\r
+ (forward-paragraph -1)\r
+ (forward-word 1)\r
+ (setq pos (point))\r
+ (setq cut (buffer-substring (point)\r
+ (save-excursion\r
+ (end-of-line)\r
+ (point))))\r
+ (delete-char (- (save-excursion (end-of-line) (point))\r
+ (point)))\r
+ (setq res (expand-abbrev))\r
+ (save-excursion\r
+ (goto-char pos)\r
+ (insert cut))\r
+ res))\r
+ nil\r
+ (cperl-ensure-newlines (if cut 2 4))\r
+ (forward-line 2)))\r
+ ((get-text-property (point) 'in-pod) ; In POD section\r
+ (cperl-ensure-newlines 4)\r
+ (forward-line 2))\r
+ ((looking-at "\n[ \t]*$") ; Next line is empty - use it.\r
+ (forward-line 1)\r
+ (cperl-indent-line))\r
+ (t\r
+ (newline-and-indent))))))\r
+\r
+(defun cperl-electric-semi (arg)\r
+ "Insert character and correct line's indentation."\r
+ (interactive "P")\r
+ (if cperl-auto-newline\r
+ (cperl-electric-terminator arg)\r
+ (self-insert-command (prefix-numeric-value arg))\r
+ (if cperl-autoindent-on-semi\r
+ (cperl-indent-line))))\r
+\r
+(defun cperl-electric-terminator (arg)\r
+ "Insert character and correct line's indentation."\r
+ (interactive "P")\r
+ (let ((end (point))\r
+ (auto (and cperl-auto-newline\r
+ (or (not (eq last-command-char ?:))\r
+ cperl-auto-newline-after-colon)))\r
+ insertpos)\r
+ (if (and ;;(not arg)\r
+ (eolp)\r
+ (not (save-excursion\r
+ (beginning-of-line)\r
+ (skip-chars-forward " \t")\r
+ (or\r
+ ;; Ignore in comment lines\r
+ (= (following-char) ?#)\r
+ ;; Colon is special only after a label\r
+ ;; So quickly rule out most other uses of colon\r
+ ;; and do no indentation for them.\r
+ (and (eq last-command-char ?:)\r
+ (save-excursion\r
+ (forward-word 1)\r
+ (skip-chars-forward " \t")\r
+ (and (< (point) end)\r
+ (progn (goto-char (- end 1))\r
+ (not (looking-at ":"))))))\r
+ (progn\r
+ (beginning-of-defun)\r
+ (let ((pps (parse-partial-sexp (point) end)))\r
+ (or (nth 3 pps) (nth 4 pps) (nth 5 pps))))))))\r
+ (progn\r
+ (self-insert-command (prefix-numeric-value arg))\r
+ ;;(forward-char -1)\r
+ (if auto (setq insertpos (point-marker)))\r
+ ;;(forward-char 1)\r
+ (cperl-indent-line)\r
+ (if auto\r
+ (progn\r
+ (newline)\r
+ (cperl-indent-line)))\r
+ (save-excursion\r
+ (if insertpos (goto-char (1- (marker-position insertpos)))\r
+ (forward-char -1))\r
+ (delete-char 1))))\r
+ (if insertpos\r
+ (save-excursion\r
+ (goto-char insertpos)\r
+ (self-insert-command (prefix-numeric-value arg)))\r
+ (self-insert-command (prefix-numeric-value arg)))))\r
+\r
+(defun cperl-electric-backspace (arg)\r
+ "Backspace, or remove the whitespace around the point inserted by an electric\r
+key. Will untabivy if `cperl-electric-backspace-untabify' is non-nil."\r
+ (interactive "p")\r
+ (if (and cperl-auto-newline\r
+ (memq last-command '(cperl-electric-semi\r
+ cperl-electric-terminator\r
+ cperl-electric-lbrace))\r
+ (memq (preceding-char) '(?\ ?\t ?\n)))\r
+ (let (p)\r
+ (if (eq last-command 'cperl-electric-lbrace)\r
+ (skip-chars-forward " \t\n"))\r
+ (setq p (point))\r
+ (skip-chars-backward " \t\n")\r
+ (delete-region (point) p))\r
+ (and (eq last-command 'cperl-electric-else)\r
+ ;; We are removing the whitespace *inside* cperl-electric-else\r
+ (setq this-command 'cperl-electric-else-really))\r
+ (if (and cperl-auto-newline\r
+ (eq last-command 'cperl-electric-else-really)\r
+ (memq (preceding-char) '(?\ ?\t ?\n)))\r
+ (let (p)\r
+ (skip-chars-forward " \t\n")\r
+ (setq p (point))\r
+ (skip-chars-backward " \t\n")\r
+ (delete-region (point) p))\r
+ (if cperl-electric-backspace-untabify\r
+ (backward-delete-char-untabify arg)\r
+ (delete-backward-char arg)))))\r
+\r
+(defun cperl-inside-parens-p ()\r
+ (condition-case ()\r
+ (save-excursion\r
+ (save-restriction\r
+ (narrow-to-region (point)\r
+ (progn (beginning-of-defun) (point)))\r
+ (goto-char (point-max))\r
+ (= (char-after (or (scan-lists (point) -1 1) (point-min))) ?\()))\r
+ (error nil)))\r
+\f\r
+(defun cperl-indent-command (&optional whole-exp)\r
+ "Indent current line as Perl code, or in some cases insert a tab character.\r
+If `cperl-tab-always-indent' is non-nil (the default), always indent current\r
+line. Otherwise, indent the current line only if point is at the left margin\r
+or in the line's indentation; otherwise insert a tab.\r
+\r
+A numeric argument, regardless of its value,\r
+means indent rigidly all the lines of the expression starting after point\r
+so that this line becomes properly indented.\r
+The relative indentation among the lines of the expression are preserved."\r
+ (interactive "P")\r
+ (cperl-update-syntaxification (point) (point))\r
+ (if whole-exp\r
+ ;; If arg, always indent this line as Perl\r
+ ;; and shift remaining lines of expression the same amount.\r
+ (let ((shift-amt (cperl-indent-line))\r
+ beg end)\r
+ (save-excursion\r
+ (if cperl-tab-always-indent\r
+ (beginning-of-line))\r
+ (setq beg (point))\r
+ (forward-sexp 1)\r
+ (setq end (point))\r
+ (goto-char beg)\r
+ (forward-line 1)\r
+ (setq beg (point)))\r
+ (if (and shift-amt (> end beg))\r
+ (indent-code-rigidly beg end shift-amt "#")))\r
+ (if (and (not cperl-tab-always-indent)\r
+ (save-excursion\r
+ (skip-chars-backward " \t")\r
+ (not (bolp))))\r
+ (insert-tab)\r
+ (cperl-indent-line))))\r
+\r
+(defun cperl-indent-line (&optional parse-data)\r
+ "Indent current line as Perl code.\r
+Return the amount the indentation changed by."\r
+ (let ((case-fold-search nil)\r
+ (pos (- (point-max) (point)))\r
+ indent i beg shift-amt)\r
+ (setq indent (cperl-calculate-indent parse-data)\r
+ i indent)\r
+ (beginning-of-line)\r
+ (setq beg (point))\r
+ (cond ((or (eq indent nil) (eq indent t))\r
+ (setq indent (current-indentation) i nil))\r
+ ;;((eq indent t) ; Never?\r
+ ;; (setq indent (cperl-calculate-indent-within-comment)))\r
+ ;;((looking-at "[ \t]*#")\r
+ ;; (setq indent 0))\r
+ (t\r
+ (skip-chars-forward " \t")\r
+ (if (listp indent) (setq indent (car indent)))\r
+ (cond ((looking-at "[A-Za-z_][A-Za-z_0-9]*:[^:]")\r
+ (and (> indent 0)\r
+ (setq indent (max cperl-min-label-indent\r
+ (+ indent cperl-label-offset)))))\r
+ ((= (following-char) ?})\r
+ (setq indent (- indent cperl-indent-level)))\r
+ ((memq (following-char) '(?\) ?\])) ; To line up with opening paren.\r
+ (setq indent (+ indent cperl-close-paren-offset)))\r
+ ((= (following-char) ?{)\r
+ (setq indent (+ indent cperl-brace-offset))))))\r
+ (skip-chars-forward " \t")\r
+ (setq shift-amt (and i (- indent (current-column))))\r
+ (if (or (not shift-amt)\r
+ (zerop shift-amt))\r
+ (if (> (- (point-max) pos) (point))\r
+ (goto-char (- (point-max) pos)))\r
+ (delete-region beg (point))\r
+ (indent-to indent)\r
+ ;; If initial point was within line's indentation,\r
+ ;; position after the indentation. Else stay at same point in text.\r
+ (if (> (- (point-max) pos) (point))\r
+ (goto-char (- (point-max) pos))))\r
+ shift-amt))\r
+\r
+(defun cperl-after-label ()\r
+ ;; Returns true if the point is after label. Does not do save-excursion.\r
+ (and (eq (preceding-char) ?:)\r
+ (memq (char-syntax (char-after (- (point) 2)))\r
+ '(?w ?_))\r
+ (progn\r
+ (backward-sexp)\r
+ (looking-at "[a-zA-Z_][a-zA-Z0-9_]*:[^:]"))))\r
+\r
+(defun cperl-get-state (&optional parse-start start-state)\r
+ ;; returns list (START STATE DEPTH PRESTART),\r
+ ;; START is a good place to start parsing, or equal to\r
+ ;; PARSE-START if preset,\r
+ ;; STATE is what is returned by `parse-partial-sexp'.\r
+ ;; DEPTH is true is we are immediately after end of block\r
+ ;; which contains START.\r
+ ;; PRESTART is the position basing on which START was found.\r
+ (save-excursion\r
+ (let ((start-point (point)) depth state start prestart)\r
+ (if (and parse-start\r
+ (<= parse-start start-point))\r
+ (goto-char parse-start)\r
+ (beginning-of-defun)\r
+ (setq start-state nil))\r
+ (setq prestart (point))\r
+ (if start-state nil\r
+ ;; Try to go out, if sub is not on the outermost level\r
+ (while (< (point) start-point)\r
+ (setq start (point) parse-start start depth nil\r
+ state (parse-partial-sexp start start-point -1))\r
+ (if (> (car state) -1) nil\r
+ ;; The current line could start like }}}, so the indentation\r
+ ;; corresponds to a different level than what we reached\r
+ (setq depth t)\r
+ (beginning-of-line 2))) ; Go to the next line.\r
+ (if start (goto-char start))) ; Not at the start of file\r
+ (setq start (point))\r
+ (or state (setq state (parse-partial-sexp start start-point -1 nil start-state)))\r
+ (list start state depth prestart))))\r
+\r
+(defun cperl-block-p () ; Do not C-M-q ! One string contains ";" !\r
+ ;; Positions is before ?\{. Checks whether it starts a block.\r
+ ;; No save-excursion!\r
+ (cperl-backward-to-noncomment (point-min))\r
+ (or (memq (preceding-char) (append ";){}$@&%\C-@" nil)) ; Or label! \C-@ at bobp\r
+ ; Label may be mixed up with `$blah :'\r
+ (save-excursion (cperl-after-label))\r
+ (and (memq (char-syntax (preceding-char)) '(?w ?_))\r
+ (progn\r
+ (backward-sexp)\r
+ ;; Need take into account `bless', `return', `tr',...\r
+ (or (and (looking-at "[a-zA-Z0-9_:]+[ \t\n\f]*[{#]") ; Method call syntax\r
+ (not (looking-at "\\(bless\\|return\\|q[wqrx]?\\|tr\\|[smy]\\)\\>")))\r
+ (progn\r
+ (skip-chars-backward " \t\n\f")\r
+ (and (memq (char-syntax (preceding-char)) '(?w ?_))\r
+ (progn\r
+ (backward-sexp)\r
+ (looking-at\r
+ "sub[ \t]+[a-zA-Z0-9_:]+[ \t\n\f]*\\(([^()]*)[ \t\n\f]*\\)?[#{]")))))))))\r
+\r
+(defvar cperl-look-for-prop '((pod in-pod) (here-doc-delim here-doc-group)))\r
+\r
+(defun cperl-calculate-indent (&optional parse-data) ; was parse-start\r
+ "Return appropriate indentation for current line as Perl code.\r
+In usual case returns an integer: the column to indent to.\r
+Returns nil if line starts inside a string, t if in a comment.\r
+\r
+Will not correct the indentation for labels, but will correct it for braces\r
+and closing parentheses and brackets."\r
+ (cperl-update-syntaxification (point) (point))\r
+ (save-excursion\r
+ (if (or\r
+ (and (memq (get-text-property (point) 'syntax-type)\r
+ '(pod here-doc here-doc-delim format))\r
+ (not (get-text-property (point) 'indentable)))\r
+ ;; before start of POD - whitespace found since do not have 'pod!\r
+ (and (looking-at "[ \t]*\n=")\r
+ (error "Spaces before POD section!"))\r
+ (and (not cperl-indent-left-aligned-comments)\r
+ (looking-at "^#")))\r
+ nil\r
+ (beginning-of-line)\r
+ (let ((indent-point (point))\r
+ (char-after (save-excursion\r
+ (skip-chars-forward " \t")\r
+ (following-char)))\r
+ (in-pod (get-text-property (point) 'in-pod))\r
+ (pre-indent-point (point))\r
+ p prop look-prop is-block delim)\r
+ (cond\r
+ (in-pod\r
+ ;; In the verbatim part, probably code example. What to do???\r
+ )\r
+ (t\r
+ (save-excursion\r
+ ;; Not in POD\r
+ (cperl-backward-to-noncomment nil)\r
+ (setq p (max (point-min) (1- (point)))\r
+ prop (get-text-property p 'syntax-type)\r
+ look-prop (or (nth 1 (assoc prop cperl-look-for-prop))\r
+ 'syntax-type))\r
+ (if (memq prop '(pod here-doc format here-doc-delim))\r
+ (progn\r
+ (goto-char (or (previous-single-property-change p look-prop)\r
+ (point-min)))\r
+ (beginning-of-line)\r
+ (setq pre-indent-point (point)))))))\r
+ (goto-char pre-indent-point)\r
+ (let* ((case-fold-search nil)\r
+ (s-s (cperl-get-state (car parse-data) (nth 1 parse-data)))\r
+ (start (or (nth 2 parse-data)\r
+ (nth 0 s-s)))\r
+ (state (nth 1 s-s))\r
+ (containing-sexp (car (cdr state)))\r
+ old-indent)\r
+ (if (and\r
+ ;;containing-sexp ;; We are buggy at toplevel :-(\r
+ parse-data)\r
+ (progn\r
+ (setcar parse-data pre-indent-point)\r
+ (setcar (cdr parse-data) state)\r
+ (or (nth 2 parse-data)\r
+ (setcar (cddr parse-data) start))\r
+ ;; Before this point: end of statement\r
+ (setq old-indent (nth 3 parse-data))))\r
+ (cond ((get-text-property (point) 'indentable)\r
+ ;; indent to just after the surrounding open,\r
+ ;; skip blanks if we do not close the expression.\r
+ (goto-char (1+ (previous-single-property-change (point) 'indentable)))\r
+ (or (memq char-after (append ")]}" nil))\r
+ (looking-at "[ \t]*\\(#\\|$\\)")\r
+ (skip-chars-forward " \t"))\r
+ (current-column))\r
+ ((or (nth 3 state) (nth 4 state))\r
+ ;; return nil or t if should not change this line\r
+ (nth 4 state))\r
+ ;; XXXX Do we need to special-case this?\r
+ ((null containing-sexp)\r
+ ;; Line is at top level. May be data or function definition,\r
+ ;; or may be function argument declaration.\r
+ ;; Indent like the previous top level line\r
+ ;; unless that ends in a closeparen without semicolon,\r
+ ;; in which case this line is the first argument decl.\r
+ (skip-chars-forward " \t")\r
+ (+ (save-excursion\r
+ (goto-char start)\r
+ (- (current-indentation)\r
+ (if (nth 2 s-s) cperl-indent-level 0)))\r
+ (if (= char-after ?{) cperl-continued-brace-offset 0)\r
+ (progn\r
+ (cperl-backward-to-noncomment (or old-indent (point-min)))\r
+ ;; Look at previous line that's at column 0\r
+ ;; to determine whether we are in top-level decls\r
+ ;; or function's arg decls. Set basic-indent accordingly.\r
+ ;; Now add a little if this is a continuation line.\r
+ (if (or (bobp)\r
+ (eq (point) old-indent) ; old-indent was at comment\r
+ (eq (preceding-char) ?\;)\r
+ ;; Had ?\) too\r
+ (and (eq (preceding-char) ?\})\r
+ (cperl-after-block-and-statement-beg\r
+ (point-min))) ; Was start - too close\r
+ (memq char-after (append ")]}" nil))\r
+ (and (eq (preceding-char) ?\:) ; label\r
+ (progn\r
+ (forward-sexp -1)\r
+ (skip-chars-backward " \t")\r
+ (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*[ \t]*:")))\r
+ (get-text-property (point) 'first-format-line))\r
+ (progn\r
+ (if (and parse-data\r
+ (not (eq char-after ?\C-j)))\r
+ (setcdr (cddr parse-data)\r
+ (list pre-indent-point)))\r
+ 0)\r
+ cperl-continued-statement-offset))))\r
+ ((not\r
+ (or (setq is-block\r
+ (and (setq delim (= (char-after containing-sexp) ?{))\r
+ (save-excursion ; Is it a hash?\r
+ (goto-char containing-sexp)\r
+ (cperl-block-p))))\r
+ cperl-indent-parens-as-block))\r
+ ;; group is an expression, not a block:\r
+ ;; indent to just after the surrounding open parens,\r
+ ;; skip blanks if we do not close the expression.\r
+ (goto-char (1+ containing-sexp))\r
+ (or (memq char-after\r
+ (append (if delim "}" ")]}") nil))\r
+ (looking-at "[ \t]*\\(#\\|$\\)")\r
+ (skip-chars-forward " \t"))\r
+ (+ (current-column)\r
+ (if (and delim\r
+ (eq char-after ?\}))\r
+ ;; Correct indentation of trailing ?\}\r
+ (+ cperl-indent-level cperl-close-paren-offset)\r
+ 0)))\r
+;;; ((and (/= (char-after containing-sexp) ?{)\r
+;;; (not cperl-indent-parens-as-block))\r
+;;; ;; line is expression, not statement:\r
+;;; ;; indent to just after the surrounding open,\r
+;;; ;; skip blanks if we do not close the expression.\r
+;;; (goto-char (1+ containing-sexp))\r
+;;; (or (memq char-after (append ")]}" nil))\r
+;;; (looking-at "[ \t]*\\(#\\|$\\)")\r
+;;; (skip-chars-forward " \t"))\r
+;;; (current-column))\r
+;;; ((progn\r
+;;; ;; Containing-expr starts with \{. Check whether it is a hash.\r
+;;; (goto-char containing-sexp)\r
+;;; (and (not (cperl-block-p))\r
+;;; (not cperl-indent-parens-as-block)))\r
+;;; (goto-char (1+ containing-sexp))\r
+;;; (or (eq char-after ?\})\r
+;;; (looking-at "[ \t]*\\(#\\|$\\)")\r
+;;; (skip-chars-forward " \t"))\r
+;;; (+ (current-column) ; Correct indentation of trailing ?\}\r
+;;; (if (eq char-after ?\}) (+ cperl-indent-level\r
+;;; cperl-close-paren-offset)\r
+;;; 0)))\r
+ (t\r
+ ;; Statement level. Is it a continuation or a new statement?\r
+ ;; Find previous non-comment character.\r
+ (goto-char pre-indent-point)\r
+ (cperl-backward-to-noncomment containing-sexp)\r
+ ;; Back up over label lines, since they don't\r
+ ;; affect whether our line is a continuation.\r
+ ;; (Had \, too)\r
+ (while ;;(or (eq (preceding-char) ?\,)\r
+ (and (eq (preceding-char) ?:)\r
+ (or ;;(eq (char-after (- (point) 2)) ?\') ; ????\r
+ (memq (char-syntax (char-after (- (point) 2)))\r
+ '(?w ?_))))\r
+ ;;)\r
+ (if (eq (preceding-char) ?\,)\r
+ ;; Will go to beginning of line, essentially.\r
+ ;; Will ignore embedded sexpr XXXX.\r
+ (cperl-backward-to-start-of-continued-exp containing-sexp))\r
+ (beginning-of-line)\r
+ (cperl-backward-to-noncomment containing-sexp))\r
+ ;; Now we get the answer.\r
+ (if (not (or (eq (1- (point)) containing-sexp)\r
+ (memq (preceding-char)\r
+ (append (if is-block " ;{" " ,;{") '(nil)))\r
+ (and (eq (preceding-char) ?\})\r
+ (cperl-after-block-and-statement-beg\r
+ containing-sexp))\r
+ (get-text-property (point) 'first-format-line)))\r
+ ;; This line is continuation of preceding line's statement;\r
+ ;; indent `cperl-continued-statement-offset' more than the\r
+ ;; previous line of the statement.\r
+ ;;\r
+ ;; There might be a label on this line, just\r
+ ;; consider it bad style and ignore it.\r
+ (progn\r
+ (cperl-backward-to-start-of-continued-exp containing-sexp)\r
+ (+ (if (memq char-after (append "}])" nil))\r
+ 0 ; Closing parenth\r
+ cperl-continued-statement-offset)\r
+ (if (or is-block\r
+ (not delim)\r
+ (not (eq char-after ?\})))\r
+ 0\r
+ ;; Now it is a hash reference\r
+ (+ cperl-indent-level cperl-close-paren-offset))\r
+ (if (looking-at "\\w+[ \t]*:")\r
+ (if (> (current-indentation) cperl-min-label-indent)\r
+ (- (current-indentation) cperl-label-offset)\r
+ ;; Do not move `parse-data', this should\r
+ ;; be quick anyway (this comment comes\r
+ ;; from different location):\r
+ (cperl-calculate-indent))\r
+ (current-column))\r
+ (if (eq char-after ?\{)\r
+ cperl-continued-brace-offset 0)))\r
+ ;; This line starts a new statement.\r
+ ;; Position following last unclosed open.\r
+ (goto-char containing-sexp)\r
+ ;; Is line first statement after an open-brace?\r
+ (or\r
+ ;; If no, find that first statement and indent like\r
+ ;; it. If the first statement begins with label, do\r
+ ;; not believe when the indentation of the label is too\r
+ ;; small.\r
+ (save-excursion\r
+ (forward-char 1)\r
+ (setq old-indent (current-indentation))\r
+ (let ((colon-line-end 0))\r
+ (while\r
+ (progn (skip-chars-forward " \t\n")\r
+ (looking-at "#\\|[a-zA-Z0-9_$]*:[^:]\\|=[a-zA-Z]"))\r
+ ;; Skip over comments and labels following openbrace.\r
+ (cond ((= (following-char) ?\#)\r
+ (forward-line 1))\r
+ ((= (following-char) ?\=)\r
+ (goto-char\r
+ (or (next-single-property-change (point) 'in-pod)\r
+ (point-max)))) ; do not loop if no syntaxification\r
+ ;; label:\r
+ (t\r
+ (save-excursion (end-of-line)\r
+ (setq colon-line-end (point)))\r
+ (search-forward ":"))))\r
+ ;; The first following code counts\r
+ ;; if it is before the line we want to indent.\r
+ (and (< (point) indent-point)\r
+ (if (> colon-line-end (point)) ; After label\r
+ (if (> (current-indentation)\r
+ cperl-min-label-indent)\r
+ (- (current-indentation) cperl-label-offset)\r
+ ;; Do not believe: `max' is involved\r
+ (+ old-indent cperl-indent-level))\r
+ (current-column)))))\r
+ ;; If no previous statement,\r
+ ;; indent it relative to line brace is on.\r
+ ;; For open brace in column zero, don't let statement\r
+ ;; start there too. If cperl-indent-level is zero,\r
+ ;; use cperl-brace-offset + cperl-continued-statement-offset instead.\r
+ ;; For open-braces not the first thing in a line,\r
+ ;; add in cperl-brace-imaginary-offset.\r
+\r
+ ;; If first thing on a line: ?????\r
+ (+ (if (and (bolp) (zerop cperl-indent-level))\r
+ (+ cperl-brace-offset cperl-continued-statement-offset)\r
+ cperl-indent-level)\r
+ (if (or is-block\r
+ (not delim)\r
+ (not (eq char-after ?\})))\r
+ 0\r
+ ;; Now it is a hash reference\r
+ (+ cperl-indent-level cperl-close-paren-offset))\r
+ ;; Move back over whitespace before the openbrace.\r
+ ;; If openbrace is not first nonwhite thing on the line,\r
+ ;; add the cperl-brace-imaginary-offset.\r
+ (progn (skip-chars-backward " \t")\r
+ (if (bolp) 0 cperl-brace-imaginary-offset))\r
+ ;; If the openbrace is preceded by a parenthesized exp,\r
+ ;; move to the beginning of that;\r
+ ;; possibly a different line\r
+ (progn\r
+ (if (eq (preceding-char) ?\))\r
+ (forward-sexp -1))\r
+ ;; In the case it starts a subroutine, indent with\r
+ ;; respect to `sub', not with respect to the\r
+ ;; first thing on the line, say in the case of\r
+ ;; anonymous sub in a hash.\r
+ ;;\r
+ (skip-chars-backward " \t")\r
+ (if (and (eq (preceding-char) ?b)\r
+ (progn\r
+ (forward-sexp -1)\r
+ (looking-at "sub\\>"))\r
+ (setq old-indent\r
+ (nth 1\r
+ (parse-partial-sexp\r
+ (save-excursion (beginning-of-line) (point))\r
+ (point)))))\r
+ (progn (goto-char (1+ old-indent))\r
+ (skip-chars-forward " \t")\r
+ (current-column))\r
+ ;; Get initial indentation of the line we are on.\r
+ ;; If line starts with label, calculate label indentation\r
+ (if (save-excursion\r
+ (beginning-of-line)\r
+ (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]"))\r
+ (if (> (current-indentation) cperl-min-label-indent)\r
+ (- (current-indentation) cperl-label-offset)\r
+ ;; Do not move `parse-data', this should\r
+ ;; be quick anyway:\r
+ (cperl-calculate-indent))\r
+ (current-indentation))))))))))))))\r
+\r
+(defvar cperl-indent-alist\r
+ '((string nil)\r
+ (comment nil)\r
+ (toplevel 0)\r
+ (toplevel-after-parenth 2)\r
+ (toplevel-continued 2)\r
+ (expression 1))\r
+ "Alist of indentation rules for CPerl mode.\r
+The values mean:\r
+ nil: do not indent;\r
+ number: add this amount of indentation.\r
+\r
+Not finished, not used.")\r
+\r
+(defun cperl-where-am-i (&optional parse-start start-state)\r
+ ;; Unfinished\r
+ "Return a list of lists ((TYPE POS)...) of good points before the point.\r
+POS may be nil if it is hard to find, say, when TYPE is `string' or `comment'.\r
+\r
+Not finished, not used."\r
+ (save-excursion\r
+ (let* ((start-point (point))\r
+ (s-s (cperl-get-state))\r
+ (start (nth 0 s-s))\r
+ (state (nth 1 s-s))\r
+ (prestart (nth 3 s-s))\r
+ (containing-sexp (car (cdr state)))\r
+ (case-fold-search nil)\r
+ (res (list (list 'parse-start start) (list 'parse-prestart prestart))))\r
+ (cond ((nth 3 state) ; In string\r
+ (setq res (cons (list 'string nil (nth 3 state)) res))) ; What started string\r
+ ((nth 4 state) ; In comment\r
+ (setq res (cons '(comment) res)))\r
+ ((null containing-sexp)\r
+ ;; Line is at top level.\r
+ ;; Indent like the previous top level line\r
+ ;; unless that ends in a closeparen without semicolon,\r
+ ;; in which case this line is the first argument decl.\r
+ (cperl-backward-to-noncomment (or parse-start (point-min)))\r
+ ;;(skip-chars-backward " \t\f\n")\r
+ (cond\r
+ ((or (bobp)\r
+ (memq (preceding-char) (append ";}" nil)))\r
+ (setq res (cons (list 'toplevel start) res)))\r
+ ((eq (preceding-char) ?\) )\r
+ (setq res (cons (list 'toplevel-after-parenth start) res)))\r
+ (t\r
+ (setq res (cons (list 'toplevel-continued start) res)))))\r
+ ((/= (char-after containing-sexp) ?{)\r
+ ;; line is expression, not statement:\r
+ ;; indent to just after the surrounding open.\r
+ ;; skip blanks if we do not close the expression.\r
+ (setq res (cons (list 'expression-blanks\r
+ (progn\r
+ (goto-char (1+ containing-sexp))\r
+ (or (looking-at "[ \t]*\\(#\\|$\\)")\r
+ (skip-chars-forward " \t"))\r
+ (point)))\r
+ (cons (list 'expression containing-sexp) res))))\r
+ ((progn\r
+ ;; Containing-expr starts with \{. Check whether it is a hash.\r
+ (goto-char containing-sexp)\r
+ (not (cperl-block-p)))\r
+ (setq res (cons (list 'expression-blanks\r
+ (progn\r
+ (goto-char (1+ containing-sexp))\r
+ (or (looking-at "[ \t]*\\(#\\|$\\)")\r
+ (skip-chars-forward " \t"))\r
+ (point)))\r
+ (cons (list 'expression containing-sexp) res))))\r
+ (t\r
+ ;; Statement level.\r
+ (setq res (cons (list 'in-block containing-sexp) res))\r
+ ;; Is it a continuation or a new statement?\r
+ ;; Find previous non-comment character.\r
+ (cperl-backward-to-noncomment containing-sexp)\r
+ ;; Back up over label lines, since they don't\r
+ ;; affect whether our line is a continuation.\r
+ ;; Back up comma-delimited lines too ?????\r
+ (while (or (eq (preceding-char) ?\,)\r
+ (save-excursion (cperl-after-label)))\r
+ (if (eq (preceding-char) ?\,)\r
+ ;; Will go to beginning of line, essentially\r
+ ;; Will ignore embedded sexpr XXXX.\r
+ (cperl-backward-to-start-of-continued-exp containing-sexp))\r
+ (beginning-of-line)\r
+ (cperl-backward-to-noncomment containing-sexp))\r
+ ;; Now we get the answer.\r
+ (if (not (memq (preceding-char) (append ";}{" '(nil)))) ; Was ?\,\r
+ ;; This line is continuation of preceding line's statement.\r
+ (list (list 'statement-continued containing-sexp))\r
+ ;; This line starts a new statement.\r
+ ;; Position following last unclosed open.\r
+ (goto-char containing-sexp)\r
+ ;; Is line first statement after an open-brace?\r
+ (or\r
+ ;; If no, find that first statement and indent like\r
+ ;; it. If the first statement begins with label, do\r
+ ;; not believe when the indentation of the label is too\r
+ ;; small.\r
+ (save-excursion\r
+ (forward-char 1)\r
+ (let ((colon-line-end 0))\r
+ (while (progn (skip-chars-forward " \t\n" start-point)\r
+ (and (< (point) start-point)\r
+ (looking-at\r
+ "#\\|[a-zA-Z_][a-zA-Z0-9_]*:[^:]")))\r
+ ;; Skip over comments and labels following openbrace.\r
+ (cond ((= (following-char) ?\#)\r
+ ;;(forward-line 1)\r
+ (end-of-line))\r
+ ;; label:\r
+ (t\r
+ (save-excursion (end-of-line)\r
+ (setq colon-line-end (point)))\r
+ (search-forward ":"))))\r
+ ;; Now at the point, after label, or at start\r
+ ;; of first statement in the block.\r
+ (and (< (point) start-point)\r
+ (if (> colon-line-end (point))\r
+ ;; Before statement after label\r
+ (if (> (current-indentation)\r
+ cperl-min-label-indent)\r
+ (list (list 'label-in-block (point)))\r
+ ;; Do not believe: `max' is involved\r
+ (list\r
+ (list 'label-in-block-min-indent (point))))\r
+ ;; Before statement\r
+ (list 'statement-in-block (point))))))\r
+ ;; If no previous statement,\r
+ ;; indent it relative to line brace is on.\r
+ ;; For open brace in column zero, don't let statement\r
+ ;; start there too. If cperl-indent-level is zero,\r
+ ;; use cperl-brace-offset + cperl-continued-statement-offset instead.\r
+ ;; For open-braces not the first thing in a line,\r
+ ;; add in cperl-brace-imaginary-offset.\r
+\r
+ ;; If first thing on a line: ?????\r
+ (+ (if (and (bolp) (zerop cperl-indent-level))\r
+ (+ cperl-brace-offset cperl-continued-statement-offset)\r
+ cperl-indent-level)\r
+ ;; Move back over whitespace before the openbrace.\r
+ ;; If openbrace is not first nonwhite thing on the line,\r
+ ;; add the cperl-brace-imaginary-offset.\r
+ (progn (skip-chars-backward " \t")\r
+ (if (bolp) 0 cperl-brace-imaginary-offset))\r
+ ;; If the openbrace is preceded by a parenthesized exp,\r
+ ;; move to the beginning of that;\r
+ ;; possibly a different line\r
+ (progn\r
+ (if (eq (preceding-char) ?\))\r
+ (forward-sexp -1))\r
+ ;; Get initial indentation of the line we are on.\r
+ ;; If line starts with label, calculate label indentation\r
+ (if (save-excursion\r
+ (beginning-of-line)\r
+ (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]"))\r
+ (if (> (current-indentation) cperl-min-label-indent)\r
+ (- (current-indentation) cperl-label-offset)\r
+ (cperl-calculate-indent))\r
+ (current-indentation))))))))\r
+ res)))\r
+\r
+(defun cperl-calculate-indent-within-comment ()\r
+ "Return the indentation amount for line, assuming that\r
+the current line is to be regarded as part of a block comment."\r
+ (let (end star-start)\r
+ (save-excursion\r
+ (beginning-of-line)\r
+ (skip-chars-forward " \t")\r
+ (setq end (point))\r
+ (and (= (following-char) ?#)\r
+ (forward-line -1)\r
+ (cperl-to-comment-or-eol)\r
+ (setq end (point)))\r
+ (goto-char end)\r
+ (current-column))))\r
+\r
+\r
+(defun cperl-to-comment-or-eol ()\r
+ "Go to position before comment on the current line, or to end of line.\r
+Returns true if comment is found."\r
+ (let (state stop-in cpoint (lim (progn (end-of-line) (point))))\r
+ (beginning-of-line)\r
+ (if (or\r
+ (eq (get-text-property (point) 'syntax-type) 'pod)\r
+ (re-search-forward "\\=[ \t]*\\(#\\|$\\)" lim t))\r
+ (if (eq (preceding-char) ?\#) (progn (backward-char 1) t))\r
+ ;; Else\r
+ (while (not stop-in)\r
+ (setq state (parse-partial-sexp (point) lim nil nil nil t))\r
+ ; stop at comment\r
+ ;; If fails (beginning-of-line inside sexp), then contains not-comment\r
+ (if (nth 4 state) ; After `#';\r
+ ; (nth 2 state) can be\r
+ ; beginning of m,s,qq and so\r
+ ; on\r
+ (if (nth 2 state)\r
+ (progn\r
+ (setq cpoint (point))\r
+ (goto-char (nth 2 state))\r
+ (cond\r
+ ((looking-at "\\(s\\|tr\\)\\>")\r
+ (or (re-search-forward\r
+ "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*"\r
+ lim 'move)\r
+ (setq stop-in t)))\r
+ ((looking-at "\\(m\\|q\\([qxwr]\\)?\\)\\>")\r
+ (or (re-search-forward\r
+ "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#"\r
+ lim 'move)\r
+ (setq stop-in t)))\r
+ (t ; It was fair comment\r
+ (setq stop-in t) ; Finish\r
+ (goto-char (1- cpoint)))))\r
+ (setq stop-in t) ; Finish\r
+ (forward-char -1))\r
+ (setq stop-in t))) ; Finish \r
+ (nth 4 state))))\r
+\r
+(defsubst cperl-1- (p)\r
+ (max (point-min) (1- p)))\r
+\r
+(defsubst cperl-1+ (p)\r
+ (min (point-max) (1+ p)))\r
+\r
+(defsubst cperl-modify-syntax-type (at how)\r
+ (if (< at (point-max))\r
+ (progn\r
+ (put-text-property at (1+ at) 'syntax-table how)\r
+ (put-text-property at (1+ at) 'rear-nonsticky t))))\r
+\r
+(defun cperl-protect-defun-start (s e)\r
+ ;; C code looks for "^\\s(" to skip comment backward in "hard" situations\r
+ (save-excursion\r
+ (goto-char s)\r
+ (while (re-search-forward "^\\s(" e 'to-end)\r
+ (put-text-property (1- (point)) (point) 'syntax-table cperl-st-punct))))\r
+\r
+(defun cperl-commentify (bb e string &optional noface)\r
+ (if cperl-use-syntax-table-text-property\r
+ (if (eq noface 'n) ; Only immediate\r
+ nil\r
+ ;; We suppose that e is _after_ the end of construction, as after eol.\r
+ (setq string (if string cperl-st-sfence cperl-st-cfence))\r
+ (if (> bb (- e 2))\r
+ ;; one-char string/comment?!\r
+ (cperl-modify-syntax-type bb cperl-st-punct)\r
+ (cperl-modify-syntax-type bb string)\r
+ (cperl-modify-syntax-type (1- e) string))\r
+ (if (and (eq string cperl-st-sfence) (> (- e 2) bb))\r
+ (put-text-property (1+ bb) (1- e)\r
+ 'syntax-table cperl-string-syntax-table))\r
+ (cperl-protect-defun-start bb e))\r
+ ;; Fontify\r
+ (or noface\r
+ (not cperl-pod-here-fontify)\r
+ (put-text-property bb e 'face (if string 'font-lock-string-face\r
+ 'font-lock-comment-face)))))\r
+\r
+(defvar cperl-starters '(( ?\( . ?\) )\r
+ ( ?\[ . ?\] )\r
+ ( ?\{ . ?\} )\r
+ ( ?\< . ?\> )))\r
+\r
+(defun cperl-forward-re (lim end is-2arg set-st st-l err-l argument\r
+ &optional ostart oend)\r
+ ;; Works *before* syntax recognition is done\r
+ ;; May modify syntax-type text property if the situation is too hard\r
+ (let (b starter ender st i i2 go-forward reset-st)\r
+ (skip-chars-forward " \t")\r
+ ;; ender means matching-char matcher.\r
+ (setq b (point)\r
+ starter (if (eobp) 0 (char-after b))\r
+ ender (cdr (assoc starter cperl-starters)))\r
+ ;; What if starter == ?\\ ????\r
+ (if set-st\r
+ (if (car st-l)\r
+ (setq st (car st-l))\r
+ (setcar st-l (make-syntax-table))\r
+ (setq i 0 st (car st-l))\r
+ (while (< i 256)\r
+ (modify-syntax-entry i "." st)\r
+ (setq i (1+ i)))\r
+ (modify-syntax-entry ?\\ "\\" st)))\r
+ (setq set-st t)\r
+ ;; Whether we have an intermediate point\r
+ (setq i nil)\r
+ ;; Prepare the syntax table:\r
+ (and set-st\r
+ (if (not ender) ; m/blah/, s/x//, s/x/y/\r
+ (modify-syntax-entry starter "$" st)\r
+ (modify-syntax-entry starter (concat "(" (list ender)) st)\r
+ (modify-syntax-entry ender (concat ")" (list starter)) st)))\r
+ (condition-case bb\r
+ (progn\r
+ ;; We use `$' syntax class to find matching stuff, but $$\r
+ ;; is recognized the same as $, so we need to check this manually.\r
+ (if (and (eq starter (char-after (cperl-1+ b)))\r
+ (not ender))\r
+ ;; $ has TeXish matching rules, so $$ equiv $...\r
+ (forward-char 2)\r
+ (setq reset-st (syntax-table))\r
+ (set-syntax-table st)\r
+ (forward-sexp 1)\r
+ (if (<= (point) (1+ b))\r
+ (error "Unfinished regular expression"))\r
+ (set-syntax-table reset-st)\r
+ (setq reset-st nil)\r
+ ;; Now the problem is with m;blah;;\r
+ (and (not ender)\r
+ (eq (preceding-char)\r
+ (char-after (- (point) 2)))\r
+ (save-excursion\r
+ (forward-char -2)\r
+ (= 0 (% (skip-chars-backward "\\\\") 2)))\r
+ (forward-char -1)))\r
+ ;; Now we are after the first part.\r
+ (and is-2arg ; Have trailing part\r
+ (not ender)\r
+ (eq (following-char) starter) ; Empty trailing part\r
+ (progn\r
+ (or (eq (char-syntax (following-char)) ?.)\r
+ ;; Make trailing letter into punctuation\r
+ (cperl-modify-syntax-type (point) cperl-st-punct))\r
+ (setq is-2arg nil go-forward t))) ; Ignore the tail\r
+ (if is-2arg ; Not number => have second part\r
+ (progn\r
+ (setq i (point) i2 i)\r
+ (if ender\r
+ (if (memq (following-char) '(?\ ?\t ?\n ?\f))\r
+ (progn\r
+ (if (looking-at "[ \t\n\f]+\\(#[^\n]*\n[ \t\n\f]*\\)+")\r
+ (goto-char (match-end 0))\r
+ (skip-chars-forward " \t\n\f"))\r
+ (setq i2 (point))))\r
+ (forward-char -1))\r
+ (modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st)\r
+ (if ender (modify-syntax-entry ender "." st))\r
+ (setq set-st nil)\r
+ (setq ender (cperl-forward-re lim end nil t st-l err-l\r
+ argument starter ender)\r
+ ender (nth 2 ender)))))\r
+ (error (goto-char lim)\r
+ (setq set-st nil)\r
+ (if reset-st\r
+ (set-syntax-table reset-st))\r
+ (or end\r
+ (message\r
+ "End of `%s%s%c ... %c' string/RE not found: %s"\r
+ argument\r
+ (if ostart (format "%c ... %c" ostart (or oend ostart)) "")\r
+ starter (or ender starter) bb)\r
+ (or (car err-l) (setcar err-l b)))))\r
+ (if set-st\r
+ (progn\r
+ (modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st)\r
+ (if ender (modify-syntax-entry ender "." st))))\r
+ ;; i: have 2 args, after end of the first arg\r
+ ;; i2: start of the second arg, if any (before delim iff `ender').\r
+ ;; ender: the last arg bounded by parens-like chars, the second one of them\r
+ ;; starter: the starting delimiter of the first arg\r
+ ;; go-forward: has 2 args, and the second part is empty\r
+ (list i i2 ender starter go-forward)))\r
+\r
+(defvar font-lock-string-face)\r
+;;(defvar font-lock-reference-face)\r
+(defvar font-lock-constant-face)\r
+(defsubst cperl-postpone-fontification (b e type val &optional now)\r
+ ;; Do after syntactic fontification?\r
+ (if cperl-syntaxify-by-font-lock\r
+ (or now (put-text-property b e 'cperl-postpone (cons type val)))\r
+ (put-text-property b e type val)))\r
+\r
+;;; Here is how the global structures (those which cannot be\r
+;;; recognized locally) are marked:\r
+;; a) PODs:\r
+;; Start-to-end is marked `in-pod' ==> t\r
+;; Each non-literal part is marked `syntax-type' ==> `pod'\r
+;; Each literal part is marked `syntax-type' ==> `in-pod'\r
+;; b) HEREs:\r
+;; Start-to-end is marked `here-doc-group' ==> t\r
+;; The body is marked `syntax-type' ==> `here-doc'\r
+;; The delimiter is marked `syntax-type' ==> `here-doc-delim'\r
+;; c) FORMATs:\r
+;; First line (to =) marked `first-format-line' ==> t\r
+;; After-this--to-end is marked `syntax-type' ==> `format'\r
+;; d) 'Q'uoted string:\r
+;; part between markers inclusive is marked `syntax-type' ==> `string'\r
+;; part between `q' and the first marker is marked `syntax-type' ==> `prestring'\r
+\r
+(defun cperl-unwind-to-safe (before &optional end)\r
+ ;; if BEFORE, go to the previous start-of-line on each step of unwinding\r
+ (let ((pos (point)) opos)\r
+ (setq opos pos)\r
+ (while (and pos (get-text-property pos 'syntax-type))\r
+ (setq pos (previous-single-property-change pos 'syntax-type))\r
+ (if pos\r
+ (if before\r
+ (progn\r
+ (goto-char (cperl-1- pos))\r
+ (beginning-of-line)\r
+ (setq pos (point)))\r
+ (goto-char (setq pos (cperl-1- pos))))\r
+ ;; Up to the start\r
+ (goto-char (point-min))))\r
+ ;; Skip empty lines\r
+ (and (looking-at "\n*=")\r
+ (/= 0 (skip-chars-backward "\n"))\r
+ (forward-char))\r
+ (setq pos (point))\r
+ (if end\r
+ ;; Do the same for end, going small steps\r
+ (progn\r
+ (while (and end (get-text-property end 'syntax-type))\r
+ (setq pos end\r
+ end (next-single-property-change end 'syntax-type)))\r
+ (or end pos)))))\r
+\r
+(defvar cperl-nonoverridable-face)\r
+(defvar font-lock-function-name-face)\r
+(defvar font-lock-comment-face)\r
+\r
+(defun cperl-find-pods-heres (&optional min max non-inter end ignore-max)\r
+ "Scans the buffer for hard-to-parse Perl constructions.\r
+If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify\r
+the sections using `cperl-pod-head-face', `cperl-pod-face',\r
+`cperl-here-face'."\r
+ (interactive)\r
+ (or min (setq min (point-min)\r
+ cperl-syntax-state nil\r
+ cperl-syntax-done-to min))\r
+ (or max (setq max (point-max)))\r
+ (let* ((cperl-pod-here-fontify (eval cperl-pod-here-fontify)) go tmpend\r
+ face head-face here-face b e bb tag qtag b1 e1 argument i c tail tb\r
+ is-REx is-x-REx REx-comment-start REx-comment-end was-comment i2\r
+ (case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t)\r
+ (modified (buffer-modified-p))\r
+ (after-change-functions nil)\r
+ (use-syntax-state (and cperl-syntax-state\r
+ (>= min (car cperl-syntax-state))))\r
+ (state-point (if use-syntax-state\r
+ (car cperl-syntax-state)\r
+ (point-min)))\r
+ (state (if use-syntax-state\r
+ (cdr cperl-syntax-state)))\r
+ ;; (st-l '(nil)) (err-l '(nil)) ; Would overwrite - propagates from a function call to a function call!\r
+ (st-l (list nil)) (err-l (list nil))\r
+ ;; Somehow font-lock may be not loaded yet...\r
+ (font-lock-string-face (if (boundp 'font-lock-string-face)\r
+ font-lock-string-face\r
+ 'font-lock-string-face))\r
+ (font-lock-constant-face (if (boundp 'font-lock-constant-face)\r
+ font-lock-constant-face\r
+ 'font-lock-constant-face))\r
+ (font-lock-function-name-face\r
+ (if (boundp 'font-lock-function-name-face)\r
+ font-lock-function-name-face\r
+ 'font-lock-function-name-face))\r
+ (font-lock-comment-face\r
+ (if (boundp 'font-lock-comment-face)\r
+ font-lock-comment-face\r
+ 'font-lock-comment-face))\r
+ (cperl-nonoverridable-face\r
+ (if (boundp 'cperl-nonoverridable-face)\r
+ cperl-nonoverridable-face\r
+ 'cperl-nonoverridable-face))\r
+ (stop-point (if ignore-max\r
+ (point-max)\r
+ max))\r
+ (search\r
+ (concat\r
+ "\\(\\`\n?\\|^\n\\)="\r
+ "\\|"\r
+ ;; One extra () before this:\r
+ "<<"\r
+ "\\(" ; 1 + 1\r
+ ;; First variant "BLAH" or just ``.\r
+ "[ \t]*" ; Yes, whitespace is allowed!\r
+ "\\([\"'`]\\)" ; 2 + 1 = 3\r
+ "\\([^\"'`\n]*\\)" ; 3 + 1\r
+ "\\3"\r
+ "\\|"\r
+ ;; Second variant: Identifier or \ID (same as 'ID') or empty\r
+ "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 4 + 1, 5 + 1\r
+ ;; Do not have <<= or << 30 or <<30 or << $blah.\r
+ ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1\r
+ "\\(\\)" ; To preserve count of pars :-( 6 + 1\r
+ "\\)"\r
+ "\\|"\r
+ ;; 1+6 extra () before this:\r
+ "^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$"\r
+ (if cperl-use-syntax-table-text-property\r
+ (concat\r
+ "\\|"\r
+ ;; 1+6+2=9 extra () before this:\r
+ "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>"\r
+ "\\|"\r
+ ;; 1+6+2+1=10 extra () before this:\r
+ "\\([?/<]\\)" ; /blah/ or ?blah? or <file*glob>\r
+ "\\|"\r
+ ;; 1+6+2+1+1=11 extra () before this:\r
+ "\\<sub\\>[ \t]*\\([a-zA-Z_:'0-9]+[ \t]*\\)?\\(([^()]*)\\)"\r
+ "\\|"\r
+ ;; 1+6+2+1+1+2=13 extra () before this:\r
+ "\\$\\(['{]\\)"\r
+ "\\|"\r
+ ;; 1+6+2+1+1+2+1=14 extra () before this:\r
+ "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'"\r
+ ;; 1+6+2+1+1+2+1+1=15 extra () before this:\r
+ "\\|"\r
+ "__\\(END\\|DATA\\)__"\r
+ ;; 1+6+2+1+1+2+1+1+1=16 extra () before this:\r
+ "\\|"\r
+ "\\\\\\(['`\"($]\\)")\r
+ ""))))\r
+ (unwind-protect\r
+ (progn\r
+ (save-excursion\r
+ (or non-inter\r
+ (message "Scanning for \"hard\" Perl constructions..."))\r
+ (and cperl-pod-here-fontify\r
+ ;; We had evals here, do not know why...\r
+ (setq face cperl-pod-face\r
+ head-face cperl-pod-head-face\r
+ here-face cperl-here-face))\r
+ (remove-text-properties min max\r
+ '(syntax-type t in-pod t syntax-table t\r
+ cperl-postpone t\r
+ syntax-subtype t\r
+ rear-nonsticky t\r
+ here-doc-group t\r
+ first-format-line t\r
+ indentable t))\r
+ ;; Need to remove face as well...\r
+ (goto-char min)\r
+ (and (eq system-type 'emx)\r
+ (looking-at "extproc[ \t]") ; Analogue of #!\r
+ (cperl-commentify min\r
+ (save-excursion (end-of-line) (point))\r
+ nil))\r
+ (while (and\r
+ (< (point) max)\r
+ (re-search-forward search max t))\r
+ (setq tmpend nil) ; Valid for most cases\r
+ (cond\r
+ ((match-beginning 1) ; POD section\r
+ ;; "\\(\\`\n?\\|^\n\\)="\r
+ (if (looking-at "cut\\>")\r
+ (if ignore-max\r
+ nil ; Doing a chunk only\r
+ (message "=cut is not preceded by a POD section")\r
+ (or (car err-l) (setcar err-l (point))))\r
+ (beginning-of-line)\r
+\r
+ (setq b (point)\r
+ bb b\r
+ tb (match-beginning 0)\r
+ b1 nil) ; error condition\r
+ ;; We do not search to max, since we may be called from\r
+ ;; some hook of fontification, and max is random\r
+ (or (re-search-forward "^\n=cut\\>" stop-point 'toend)\r
+ (progn\r
+ (goto-char b)\r
+ (if (re-search-forward "\n=cut\\>" stop-point 'toend)\r
+ (progn\r
+ (message "=cut is not preceded by an empty line")\r
+ (setq b1 t)\r
+ (or (car err-l) (setcar err-l b))))))\r
+ (beginning-of-line 2) ; An empty line after =cut is not POD!\r
+ (setq e (point))\r
+ (and (> e max)\r
+ (progn\r
+ (remove-text-properties\r
+ max e '(syntax-type t in-pod t syntax-table t\r
+ cperl-postpone t\r
+ syntax-subtype t\r
+ here-doc-group t\r
+ rear-nonsticky t\r
+ first-format-line t\r
+ indentable t))\r
+ (setq tmpend tb)))\r
+ (put-text-property b e 'in-pod t)\r
+ (put-text-property b e 'syntax-type 'in-pod)\r
+ (goto-char b)\r
+ (while (re-search-forward "\n\n[ \t]" e t)\r
+ ;; We start 'pod 1 char earlier to include the preceding line\r
+ (beginning-of-line)\r
+ (put-text-property (cperl-1- b) (point) 'syntax-type 'pod)\r
+ (cperl-put-do-not-fontify b (point) t)\r
+ ;; mark the non-literal parts as PODs\r
+ (if cperl-pod-here-fontify\r
+ (cperl-postpone-fontification b (point) 'face face t))\r
+ (re-search-forward "\n\n[^ \t\f\n]" e 'toend)\r
+ (beginning-of-line)\r
+ (setq b (point)))\r
+ (put-text-property (cperl-1- (point)) e 'syntax-type 'pod)\r
+ (cperl-put-do-not-fontify (point) e t)\r
+ (if cperl-pod-here-fontify\r
+ (progn\r
+ ;; mark the non-literal parts as PODs\r
+ (cperl-postpone-fontification (point) e 'face face t)\r
+ (goto-char bb)\r
+ (if (looking-at\r
+ "=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$")\r
+ ;; mark the headers\r
+ (cperl-postpone-fontification\r
+ (match-beginning 1) (match-end 1)\r
+ 'face head-face))\r
+ (while (re-search-forward\r
+ ;; One paragraph\r
+ "^\n=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$"\r
+ e 'toend)\r
+ ;; mark the headers\r
+ (cperl-postpone-fontification\r
+ (match-beginning 1) (match-end 1)\r
+ 'face head-face))))\r
+ (cperl-commentify bb e nil)\r
+ (goto-char e)\r
+ (or (eq e (point-max))\r
+ (forward-char -1)))) ; Prepare for immediate POD start.\r
+ ;; Here document\r
+ ;; We do only one here-per-line\r
+ ;; ;; One extra () before this:\r
+ ;;"<<"\r
+ ;; "\\(" ; 1 + 1\r
+ ;; ;; First variant "BLAH" or just ``.\r
+ ;; "[ \t]*" ; Yes, whitespace is allowed!\r
+ ;; "\\([\"'`]\\)" ; 2 + 1\r
+ ;; "\\([^\"'`\n]*\\)" ; 3 + 1\r
+ ;; "\\3"\r
+ ;; "\\|"\r
+ ;; ;; Second variant: Identifier or \ID or empty\r
+ ;; "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 4 + 1, 5 + 1\r
+ ;; ;; Do not have <<= or << 30 or <<30 or << $blah.\r
+ ;; ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1\r
+ ;; "\\(\\)" ; To preserve count of pars :-( 6 + 1\r
+ ;; "\\)"\r
+ ((match-beginning 2) ; 1 + 1\r
+ ;; Abort in comment:\r
+ (setq b (point))\r
+ (setq state (parse-partial-sexp state-point b nil nil state)\r
+ state-point b\r
+ tb (match-beginning 0)\r
+ i (or (nth 3 state) (nth 4 state)))\r
+ (if i\r
+ (setq c t)\r
+ (setq c (and\r
+ (match-beginning 5)\r
+ (not (match-beginning 6)) ; Empty\r
+ (looking-at\r
+ "[ \t]*[=0-9$@%&(]"))))\r
+ (if c ; Not here-doc\r
+ nil ; Skip it.\r
+ (if (match-beginning 5) ;4 + 1\r
+ (setq b1 (match-beginning 5) ; 4 + 1\r
+ e1 (match-end 5)) ; 4 + 1\r
+ (setq b1 (match-beginning 4) ; 3 + 1\r
+ e1 (match-end 4))) ; 3 + 1\r
+ (setq tag (buffer-substring b1 e1)\r
+ qtag (regexp-quote tag))\r
+ (cond (cperl-pod-here-fontify\r
+ ;; Highlight the starting delimiter\r
+ (cperl-postpone-fontification b1 e1 'face font-lock-constant-face)\r
+ (cperl-put-do-not-fontify b1 e1 t)))\r
+ (forward-line)\r
+ (setq b (point))\r
+ ;; We do not search to max, since we may be called from\r
+ ;; some hook of fontification, and max is random\r
+ (or (and (re-search-forward (concat "^" qtag "$")\r
+ stop-point 'toend)\r
+ (eq (following-char) ?\n))\r
+ (progn ; Pretend we matched at the end\r
+ (goto-char (point-max))\r
+ (re-search-forward "\\'")\r
+ (message "End of here-document `%s' not found." tag)\r
+ (or (car err-l) (setcar err-l b))))\r
+ (if cperl-pod-here-fontify\r
+ (progn\r
+ ;; Highlight the ending delimiter\r
+ (cperl-postpone-fontification (match-beginning 0) (match-end 0)\r
+ 'face font-lock-constant-face)\r
+ (cperl-put-do-not-fontify b (match-end 0) t)\r
+ ;; Highlight the HERE-DOC\r
+ (cperl-postpone-fontification b (match-beginning 0)\r
+ 'face here-face)))\r
+ (setq e1 (cperl-1+ (match-end 0)))\r
+ (put-text-property b (match-beginning 0)\r
+ 'syntax-type 'here-doc)\r
+ (put-text-property (match-beginning 0) e1\r
+ 'syntax-type 'here-doc-delim)\r
+ (put-text-property b e1\r
+ 'here-doc-group t)\r
+ (cperl-commentify b e1 nil)\r
+ (cperl-put-do-not-fontify b (match-end 0) t)\r
+ (if (> e1 max)\r
+ (setq tmpend tb))))\r
+ ;; format\r
+ ((match-beginning 8)\r
+ ;; 1+6=7 extra () before this:\r
+ ;;"^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$"\r
+ (setq b (point)\r
+ name (if (match-beginning 8) ; 7 + 1\r
+ (buffer-substring (match-beginning 8) ; 7 + 1\r
+ (match-end 8)) ; 7 + 1\r
+ "")\r
+ tb (match-beginning 0))\r
+ (setq argument nil)\r
+ (put-text-property (save-excursion\r
+ (beginning-of-line)\r
+ (point))\r
+ b 'first-format-line 't)\r
+ (if cperl-pod-here-fontify\r
+ (while (and (eq (forward-line) 0)\r
+ (not (looking-at "^[.;]$")))\r
+ (cond\r
+ ((looking-at "^#")) ; Skip comments\r
+ ((and argument ; Skip argument multi-lines\r
+ (looking-at "^[ \t]*{"))\r
+ (forward-sexp 1)\r
+ (setq argument nil))\r
+ (argument ; Skip argument lines\r
+ (setq argument nil))\r
+ (t ; Format line\r
+ (setq b1 (point))\r
+ (setq argument (looking-at "^[^\n]*[@^]"))\r
+ (end-of-line)\r
+ ;; Highlight the format line\r
+ (cperl-postpone-fontification b1 (point)\r
+ 'face font-lock-string-face)\r
+ (cperl-commentify b1 (point) nil)\r
+ (cperl-put-do-not-fontify b1 (point) t))))\r
+ ;; We do not search to max, since we may be called from\r
+ ;; some hook of fontification, and max is random\r
+ (re-search-forward "^[.;]$" stop-point 'toend))\r
+ (beginning-of-line)\r
+ (if (looking-at "^\\.$") ; ";" is not supported yet\r
+ (progn\r
+ ;; Highlight the ending delimiter\r
+ (cperl-postpone-fontification (point) (+ (point) 2)\r
+ 'face font-lock-string-face)\r
+ (cperl-commentify (point) (+ (point) 2) nil)\r
+ (cperl-put-do-not-fontify (point) (+ (point) 2) t))\r
+ (message "End of format `%s' not found." name)\r
+ (or (car err-l) (setcar err-l b)))\r
+ (forward-line)\r
+ (if (> (point) max)\r
+ (setq tmpend tb))\r
+ (put-text-property b (point) 'syntax-type 'format))\r
+ ;; Regexp:\r
+ ((or (match-beginning 10) (match-beginning 11))\r
+ ;; 1+6+2=9 extra () before this:\r
+ ;; "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>"\r
+ ;; "\\|"\r
+ ;; "\\([?/<]\\)" ; /blah/ or ?blah? or <file*glob>\r
+ (setq b1 (if (match-beginning 10) 10 11)\r
+ argument (buffer-substring\r
+ (match-beginning b1) (match-end b1))\r
+ b (point)\r
+ i b\r
+ c (char-after (match-beginning b1))\r
+ bb (char-after (1- (match-beginning b1))) ; tmp holder\r
+ ;; bb == "Not a stringy"\r
+ bb (if (eq b1 10) ; user variables/whatever\r
+ (and (memq bb (append "$@%*#_:-&>" nil)) ; $#y)\r
+ (cond ((eq bb ?-) (eq c ?s)) ; -s file test\r
+ ((eq bb ?\:) ; $opt::s\r
+ (eq (char-after\r
+ (- (match-beginning b1) 2))\r
+ ?\:))\r
+ ((eq bb ?\>) ; $foo->s\r
+ (eq (char-after\r
+ (- (match-beginning b1) 2))\r
+ ?\-))\r
+ ((eq bb ?\&)\r
+ (not (eq (char-after ; &&m/blah/\r
+ (- (match-beginning b1) 2))\r
+ ?\&)))\r
+ (t t)))\r
+ ;; <file> or <$file>\r
+ (and (eq c ?\<)\r
+ ;; Do not stringify <FH>, <$fh> :\r
+ (save-match-data\r
+ (looking-at\r
+ "\\$?\\([_a-zA-Z:][_a-zA-Z0-9:]*\\)?>"))))\r
+ tb (match-beginning 0))\r
+ (goto-char (match-beginning b1))\r
+ (cperl-backward-to-noncomment (point-min))\r
+ (or bb\r
+ (if (eq b1 11) ; bare /blah/ or ?blah? or <foo>\r
+ (setq argument ""\r
+ b1 nil\r
+ bb ; Not a regexp?\r
+ (progn\r
+ (not\r
+ ;; What is below: regexp-p?\r
+ (and\r
+ (or (memq (preceding-char)\r
+ (append (if (memq c '(?\? ?\<))\r
+ ;; $a++ ? 1 : 2\r
+ "~{(=|&*!,;:"\r
+ "~{(=|&+-*!,;:") nil))\r
+ (and (eq (preceding-char) ?\})\r
+ (cperl-after-block-p (point-min)))\r
+ (and (eq (char-syntax (preceding-char)) ?w)\r
+ (progn\r
+ (forward-sexp -1)\r
+;;; After these keywords `/' starts a RE. One should add all the\r
+;;; functions/builtins which expect an argument, but ...\r
+ (if (eq (preceding-char) ?-)\r
+ ;; -d ?foo? is a RE\r
+ (looking-at "[a-zA-Z]\\>")\r
+ (and\r
+ (not (memq (preceding-char)\r
+ '(?$ ?@ ?& ?%)))\r
+ (looking-at\r
+ "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\)\\>")))))\r
+ (and (eq (preceding-char) ?.)\r
+ (eq (char-after (- (point) 2)) ?.))\r
+ (bobp))\r
+ ;; m|blah| ? foo : bar;\r
+ (not\r
+ (and (eq c ?\?)\r
+ cperl-use-syntax-table-text-property\r
+ (not (bobp))\r
+ (progn\r
+ (forward-char -1)\r
+ (looking-at "\\s|")))))))\r
+ b (1- b))\r
+ ;; s y tr m\r
+ ;; Check for $a -> y\r
+ (setq b1 (preceding-char)\r
+ go (point))\r
+ (if (and (eq b1 ?>)\r
+ (eq (char-after (- go 2)) ?-))\r
+ ;; Not a regexp\r
+ (setq bb t))))\r
+ (or bb (setq state (parse-partial-sexp\r
+ state-point b nil nil state)\r
+ state-point b))\r
+ (setq bb (or bb (nth 3 state) (nth 4 state)))\r
+ (goto-char b)\r
+ (or bb\r
+ (progn\r
+ (if (looking-at "[ \t\n\f]+\\(#[^\n]*\n[ \t\n\f]*\\)+")\r
+ (goto-char (match-end 0))\r
+ (skip-chars-forward " \t\n\f"))\r
+ (cond ((and (eq (following-char) ?\})\r
+ (eq b1 ?\{))\r
+ ;; Check for $a[23]->{ s }, @{s} and *{s::foo}\r
+ (goto-char (1- go))\r
+ (skip-chars-backward " \t\n\f")\r
+ (if (memq (preceding-char) (append "$@%&*" nil))\r
+ (setq bb t) ; @{y}\r
+ (condition-case nil\r
+ (forward-sexp -1)\r
+ (error nil)))\r
+ (if (or bb\r
+ (looking-at ; $foo -> {s}\r
+ "[$@]\\$*\\([a-zA-Z0-9_:]+\\|[^{]\\)\\([ \t\n]*->\\)?[ \t\n]*{")\r
+ (and ; $foo[12] -> {s}\r
+ (memq (following-char) '(?\{ ?\[))\r
+ (progn\r
+ (forward-sexp 1)\r
+ (looking-at "\\([ \t\n]*->\\)?[ \t\n]*{"))))\r
+ (setq bb t)\r
+ (goto-char b)))\r
+ ((and (eq (following-char) ?=)\r
+ (eq (char-after (1+ (point))) ?\>))\r
+ ;; Check for { foo => 1, s => 2 }\r
+ ;; Apparently s=> is never a substitution...\r
+ (setq bb t))\r
+ ((and (eq (following-char) ?:)\r
+ (eq b1 ?\{) ; Check for $ { s::bar }\r
+ (looking-at "::[a-zA-Z0-9_:]*[ \t\n\f]*}")\r
+ (progn \r
+ (goto-char (1- go))\r
+ (skip-chars-backward " \t\n\f")\r
+ (memq (preceding-char)\r
+ (append "$@%&*" nil))))\r
+ (setq bb t)))))\r
+ (if bb\r
+ (goto-char i)\r
+ ;; Skip whitespace and comments...\r
+ (if (looking-at "[ \t\n\f]+\\(#[^\n]*\n[ \t\n\f]*\\)+")\r
+ (goto-char (match-end 0))\r
+ (skip-chars-forward " \t\n\f"))\r
+ (if (> (point) b)\r
+ (put-text-property b (point) 'syntax-type 'prestring))\r
+ ;; qtag means two-arg matcher, may be reset to\r
+ ;; 2 or 3 later if some special quoting is needed.\r
+ ;; e1 means matching-char matcher.\r
+ (setq b (point)\r
+ ;; has 2 args\r
+ i2 (string-match "^\\([sy]\\|tr\\)$" argument)\r
+ ;; We do not search to max, since we may be called from\r
+ ;; some hook of fontification, and max is random\r
+ i (cperl-forward-re stop-point end\r
+ i2\r
+ t st-l err-l argument)\r
+ ;; Note that if `go', then it is considered as 1-arg\r
+ b1 (nth 1 i) ; start of the second part\r
+ tag (nth 2 i) ; ender-char, true if second part\r
+ ; is with matching chars []\r
+ go (nth 4 i) ; There is a 1-char part after the end\r
+ i (car i) ; intermediate point\r
+ e1 (point) ; end\r
+ ;; Before end of the second part if non-matching: ///\r
+ tail (if (and i (not tag))\r
+ (1- e1))\r
+ e (if i i e1) ; end of the first part\r
+ qtag nil ; need to preserve backslashitis\r
+ is-x-REx nil) ; REx has //x modifier\r
+ ;; Commenting \\ is dangerous, what about ( ?\r
+ (and i tail\r
+ (eq (char-after i) ?\\)\r
+ (setq qtag t))\r
+ (if (looking-at "\\sw*x") ; qr//x\r
+ (setq is-x-REx t))\r
+ (if (null i)\r
+ ;; Considered as 1arg form\r
+ (progn\r
+ (cperl-commentify b (point) t)\r
+ (put-text-property b (point) 'syntax-type 'string)\r
+ (if (or is-x-REx\r
+ ;; ignore other text properties:\r
+ (string-match "^qw$" argument))\r
+ (put-text-property b (point) 'indentable t))\r
+ (and go\r
+ (setq e1 (cperl-1+ e1))\r
+ (or (eobp)\r
+ (forward-char 1))))\r
+ (cperl-commentify b i t)\r
+ (if (looking-at "\\sw*e") ; s///e\r
+ (progn\r
+ (and\r
+ ;; silent:\r
+ (cperl-find-pods-heres b1 (1- (point)) t end)\r
+ ;; Error\r
+ (goto-char (1+ max)))\r
+ (if (and tag (eq (preceding-char) ?\>))\r
+ (progn\r
+ (cperl-modify-syntax-type (1- (point)) cperl-st-ket)\r
+ (cperl-modify-syntax-type i cperl-st-bra)))\r
+ (put-text-property b i 'syntax-type 'string)\r
+ (if is-x-REx\r
+ (put-text-property b i 'indentable t)))\r
+ (cperl-commentify b1 (point) t)\r
+ (put-text-property b (point) 'syntax-type 'string)\r
+ (if is-x-REx\r
+ (put-text-property b i 'indentable t))\r
+ (if qtag\r
+ (cperl-modify-syntax-type (1+ i) cperl-st-punct))\r
+ (setq tail nil)))\r
+ ;; Now: tail: if the second part is non-matching without ///e\r
+ (if (eq (char-syntax (following-char)) ?w)\r
+ (progn\r
+ (forward-word 1) ; skip modifiers s///s\r
+ (if tail (cperl-commentify tail (point) t))\r
+ (cperl-postpone-fontification\r
+ e1 (point) 'face 'cperl-nonoverridable-face)))\r
+ ;; Check whether it is m// which means "previous match"\r
+ ;; and highlight differently\r
+ (setq is-REx\r
+ (and (string-match "^\\([sm]?\\|qr\\)$" argument)\r
+ (or (not (= (length argument) 0))\r
+ (not (eq c ?\<)))))\r
+ (if (and is-REx\r
+ (eq e (+ 2 b))\r
+ ;; split // *is* using zero-pattern\r
+ (save-excursion\r
+ (condition-case nil\r
+ (progn\r
+ (goto-char tb)\r
+ (forward-sexp -1)\r
+ (not (looking-at "split\\>")))\r
+ (error t))))\r
+ (cperl-postpone-fontification\r
+ b e 'face font-lock-function-name-face)\r
+ (if (or i2 ; Has 2 args\r
+ (and cperl-fontify-m-as-s\r
+ (or\r
+ (string-match "^\\(m\\|qr\\)$" argument)\r
+ (and (eq 0 (length argument))\r
+ (not (eq ?\< (char-after b)))))))\r
+ (progn\r
+ (cperl-postpone-fontification\r
+ b (cperl-1+ b) 'face font-lock-constant-face)\r
+ (cperl-postpone-fontification\r
+ (1- e) e 'face font-lock-constant-face)))\r
+ (if (and is-REx cperl-regexp-scan)\r
+ ;; Process RExen better\r
+ (save-excursion\r
+ (goto-char (1+ b))\r
+ (while\r
+ (and (< (point) e)\r
+ (re-search-forward\r
+ (if is-x-REx\r
+ (if (eq (char-after b) ?\#)\r
+ "\\((\\?\\\\#\\)\\|\\(\\\\#\\)"\r
+ "\\((\\?#\\)\\|\\(#\\)")\r
+ (if (eq (char-after b) ?\#)\r
+ "\\((\\?\\\\#\\)"\r
+ "\\((\\?#\\)"))\r
+ (1- e) 'to-end))\r
+ (goto-char (match-beginning 0))\r
+ (setq REx-comment-start (point)\r
+ was-comment t)\r
+ (if (save-excursion\r
+ (and\r
+ ;; XXX not working if outside delimiter is #\r
+ (eq (preceding-char) ?\\)\r
+ (= (% (skip-chars-backward "$\\\\") 2) -1)))\r
+ ;; Not a comment, avoid loop:\r
+ (progn (setq was-comment nil)\r
+ (forward-char 1))\r
+ (if (match-beginning 2)\r
+ (progn\r
+ (beginning-of-line 2)\r
+ (if (> (point) e)\r
+ (goto-char (1- e))))\r
+ ;; Works also if the outside delimiters are ().\r
+ (or (search-forward ")" (1- e) 'toend)\r
+ (message\r
+ "Couldn't find end of (?#...)-comment in a REx, pos=%s"\r
+ REx-comment-start))))\r
+ (if (>= (point) e)\r
+ (goto-char (1- e)))\r
+ (if was-comment\r
+ (progn\r
+ (setq REx-comment-end (point))\r
+ (cperl-commentify\r
+ REx-comment-start REx-comment-end nil)\r
+ (cperl-postpone-fontification\r
+ REx-comment-start REx-comment-end\r
+ 'face font-lock-comment-face))))))\r
+ (if (and is-REx is-x-REx)\r
+ (put-text-property (1+ b) (1- e)\r
+ 'syntax-subtype 'x-REx)))\r
+ (if i2\r
+ (progn\r
+ (cperl-postpone-fontification\r
+ (1- e1) e1 'face font-lock-constant-face)\r
+ (if (assoc (char-after b) cperl-starters)\r
+ (cperl-postpone-fontification\r
+ b1 (1+ b1) 'face font-lock-constant-face))))\r
+ (if (> (point) max)\r
+ (setq tmpend tb))))\r
+ ((match-beginning 13) ; sub with prototypes\r
+ (setq b (match-beginning 0))\r
+ (if (memq (char-after (1- b))\r
+ '(?\$ ?\@ ?\% ?\& ?\*))\r
+ nil\r
+ (setq state (parse-partial-sexp\r
+ state-point b nil nil state)\r
+ state-point b)\r
+ (if (or (nth 3 state) (nth 4 state))\r
+ nil\r
+ ;; Mark as string\r
+ (cperl-commentify (match-beginning 13) (match-end 13) t))\r
+ (goto-char (match-end 0))))\r
+ ;; 1+6+2+1+1+2=13 extra () before this:\r
+ ;; "\\$\\(['{]\\)"\r
+ ((and (match-beginning 14)\r
+ (eq (preceding-char) ?\')) ; $'\r
+ (setq b (1- (point))\r
+ state (parse-partial-sexp\r
+ state-point (1- b) nil nil state)\r
+ state-point (1- b))\r
+ (if (nth 3 state) ; in string\r
+ (cperl-modify-syntax-type (1- b) cperl-st-punct))\r
+ (goto-char (1+ b)))\r
+ ;; 1+6+2+1+1+2=13 extra () before this:\r
+ ;; "\\$\\(['{]\\)"\r
+ ((match-beginning 14) ; ${\r
+ (setq bb (match-beginning 0))\r
+ (cperl-modify-syntax-type bb cperl-st-punct))\r
+ ;; 1+6+2+1+1+2+1=14 extra () before this:\r
+ ;; "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'")\r
+ ((match-beginning 15) ; old $abc'efg syntax\r
+ (setq bb (match-end 0)\r
+ b (match-beginning 0)\r
+ state (parse-partial-sexp\r
+ state-point b nil nil state)\r
+ state-point b)\r
+ (if (nth 3 state) ; in string\r
+ nil\r
+ (put-text-property (1- bb) bb 'syntax-table cperl-st-word))\r
+ (goto-char bb))\r
+ ;; 1+6+2+1+1+2+1+1=15 extra () before this:\r
+ ;; "__\\(END\\|DATA\\)__"\r
+ ((match-beginning 16) ; __END__, __DATA__\r
+ (setq bb (match-end 0)\r
+ b (match-beginning 0)\r
+ state (parse-partial-sexp\r
+ state-point b nil nil state)\r
+ state-point b)\r
+ (if (or (nth 3 state) (nth 4 state))\r
+ nil\r
+ ;; (put-text-property b (1+ bb) 'syntax-type 'pod) ; Cheat\r
+ (cperl-commentify b bb nil)\r
+ (setq end t))\r
+ (goto-char bb))\r
+ ((match-beginning 17) ; "\\\\\\(['`\"($]\\)"\r
+ ;; Trailing backslash ==> non-quoting outside string/comment\r
+ (setq bb (match-end 0)\r
+ b (match-beginning 0))\r
+ (goto-char b)\r
+ (skip-chars-backward "\\\\")\r
+ ;;;(setq i2 (= (% (skip-chars-backward "\\\\") 2) -1))\r
+ (setq state (parse-partial-sexp\r
+ state-point b nil nil state)\r
+ state-point b)\r
+ (if (or (nth 3 state) (nth 4 state) )\r
+ nil\r
+ (cperl-modify-syntax-type b cperl-st-punct))\r
+ (goto-char bb))\r
+ (t (error "Error in regexp of the sniffer")))\r
+ (if (> (point) stop-point)\r
+ (progn\r
+ (if end\r
+ (message "Garbage after __END__/__DATA__ ignored")\r
+ (message "Unbalanced syntax found while scanning")\r
+ (or (car err-l) (setcar err-l b)))\r
+ (goto-char stop-point))))\r
+ (setq cperl-syntax-state (cons state-point state)\r
+ cperl-syntax-done-to (or tmpend (max (point) max))))\r
+ (if (car err-l) (goto-char (car err-l))\r
+ (or non-inter\r
+ (message "Scanning for \"hard\" Perl constructions... done"))))\r
+ (and (buffer-modified-p)\r
+ (not modified)\r
+ (set-buffer-modified-p nil))\r
+ (set-syntax-table cperl-mode-syntax-table))\r
+ (car err-l)))\r
+\r
+(defun cperl-backward-to-noncomment (lim)\r
+ ;; Stops at lim or after non-whitespace that is not in comment\r
+ (let (stop p pr)\r
+ (while (and (not stop) (> (point) (or lim 1)))\r
+ (skip-chars-backward " \t\n\f" lim)\r
+ (setq p (point))\r
+ (beginning-of-line)\r
+ (if (memq (setq pr (get-text-property (point) 'syntax-type))\r
+ '(pod here-doc here-doc-delim))\r
+ (cperl-unwind-to-safe nil)\r
+ (or (looking-at "^[ \t]*\\(#\\|$\\)")\r
+ (progn (cperl-to-comment-or-eol) (bolp))\r
+ (progn\r
+ (skip-chars-backward " \t")\r
+ (if (< p (point)) (goto-char p))\r
+ (setq stop t)))))))\r
+\r
+(defun cperl-after-block-p (lim &optional pre-block)\r
+ "Return true if the preceeding } ends a block or a following { starts one.\r
+Would not look before LIM. If PRE-BLOCK is nil checks preceeding }.\r
+otherwise following {."\r
+ ;; We suppose that the preceding char is }.\r
+ (save-excursion\r
+ (condition-case nil\r
+ (progn\r
+ (or pre-block (forward-sexp -1))\r
+ (cperl-backward-to-noncomment lim)\r
+ (or (eq (point) lim)\r
+ (eq (preceding-char) ?\) ) ; if () {} sub f () {}\r
+ (if (eq (char-syntax (preceding-char)) ?w) ; else {}\r
+ (save-excursion\r
+ (forward-sexp -1)\r
+ (or (looking-at "\\(else\\|continue\\|grep\\|map\\|BEGIN\\|END\\|CHECK\\|INIT\\)\\>")\r
+ ;; sub f {}\r
+ (progn\r
+ (cperl-backward-to-noncomment lim)\r
+ (and (eq (char-syntax (preceding-char)) ?w)\r
+ (progn\r
+ (forward-sexp -1)\r
+ (looking-at "sub\\>"))))))\r
+ (cperl-after-expr-p lim))))\r
+ (error nil))))\r
+\r
+(defun cperl-after-expr-p (&optional lim chars test)\r
+ "Return true if the position is good for start of expression.\r
+TEST is the expression to evaluate at the found position. If absent,\r
+CHARS is a string that contains good characters to have before us (however,\r
+`}' is treated \"smartly\" if it is not in the list)."\r
+ (let ((lim (or lim (point-min)))\r
+ stop p pr)\r
+ (cperl-update-syntaxification (point) (point))\r
+ (save-excursion\r
+ (while (and (not stop) (> (point) lim))\r
+ (skip-chars-backward " \t\n\f" lim)\r
+ (setq p (point))\r
+ (beginning-of-line)\r
+ ;;(memq (setq pr (get-text-property (point) 'syntax-type))\r
+ ;; '(pod here-doc here-doc-delim))\r
+ (if (get-text-property (point) 'here-doc-group)\r
+ (progn\r
+ (goto-char\r
+ (previous-single-property-change (point) 'here-doc-group))\r
+ (beginning-of-line 0)))\r
+ (if (get-text-property (point) 'in-pod)\r
+ (progn\r
+ (goto-char\r
+ (previous-single-property-change (point) 'in-pod))\r
+ (beginning-of-line 0)))\r
+ (if (looking-at "^[ \t]*\\(#\\|$\\)") nil ; Only comment, skip\r
+ ;; Else: last iteration, or a label\r
+ (cperl-to-comment-or-eol) ; Will not move past "." after a format\r
+ (skip-chars-backward " \t")\r
+ (if (< p (point)) (goto-char p))\r
+ (setq p (point))\r
+ (if (and (eq (preceding-char) ?:)\r
+ (progn\r
+ (forward-char -1)\r
+ (skip-chars-backward " \t\n\f" lim)\r
+ (eq (char-syntax (preceding-char)) ?w)))\r
+ (forward-sexp -1) ; Possibly label. Skip it\r
+ (goto-char p)\r
+ (setq stop t))))\r
+ (or (bobp) ; ???? Needed\r
+ (eq (point) lim)\r
+ (looking-at "[ \t]*__\\(END\\|DATA\\)__") ; After this anything goes\r
+ (progn\r
+ (if test (eval test)\r
+ (or (memq (preceding-char) (append (or chars "{;") nil))\r
+ (and (eq (preceding-char) ?\})\r
+ (cperl-after-block-p lim))\r
+ (and (eq (following-char) ?.) ; in format: see comment above\r
+ (eq (get-text-property (point) 'syntax-type)\r
+ 'format)))))))))\r
+\r
+(defun cperl-backward-to-start-of-continued-exp (lim)\r
+ (if (memq (preceding-char) (append ")]}\"'`" nil))\r
+ (forward-sexp -1))\r
+ (beginning-of-line)\r
+ (if (<= (point) lim)\r
+ (goto-char (1+ lim)))\r
+ (skip-chars-forward " \t"))\r
+\r
+(defun cperl-after-block-and-statement-beg (lim)\r
+ ;; We assume that we are after ?\}\r
+ (and\r
+ (cperl-after-block-p lim)\r
+ (save-excursion\r
+ (forward-sexp -1)\r
+ (cperl-backward-to-noncomment (point-min))\r
+ (or (bobp)\r
+ (eq (point) lim)\r
+ (not (= (char-syntax (preceding-char)) ?w))\r
+ (progn\r
+ (forward-sexp -1)\r
+ (not\r
+ (looking-at\r
+ "\\(map\\|grep\\|printf?\\|system\\|exec\\|tr\\|s\\)\\>")))))))\r
+\r
+\f\r
+(defvar innerloop-done nil)\r
+(defvar last-depth nil)\r
+\r
+(defun cperl-indent-exp ()\r
+ "Simple variant of indentation of continued-sexp.\r
+\r
+Will not indent comment if it starts at `comment-indent' or looks like\r
+continuation of the comment on the previous line.\r
+\r
+If `cperl-indent-region-fix-constructs', will improve spacing on\r
+conditional/loop constructs."\r
+ (interactive)\r
+ (save-excursion\r
+ (let ((tmp-end (progn (end-of-line) (point))) top done)\r
+ (save-excursion\r
+ (beginning-of-line)\r
+ (while (null done)\r
+ (setq top (point))\r
+ (while (= (nth 0 (parse-partial-sexp (point) tmp-end\r
+ -1)) -1)\r
+ (setq top (point))) ; Get the outermost parenths in line\r
+ (goto-char top)\r
+ (while (< (point) tmp-end)\r
+ (parse-partial-sexp (point) tmp-end nil t) ; To start-sexp or eol\r
+ (or (eolp) (forward-sexp 1)))\r
+ (if (> (point) tmp-end)\r
+ (save-excursion\r
+ (end-of-line)\r
+ (setq tmp-end (point)))\r
+ (setq done t)))\r
+ (goto-char tmp-end)\r
+ (setq tmp-end (point-marker)))\r
+ (if cperl-indent-region-fix-constructs\r
+ (cperl-fix-line-spacing tmp-end))\r
+ (cperl-indent-region (point) tmp-end))))\r
+\r
+(defun cperl-fix-line-spacing (&optional end parse-data)\r
+ "Improve whitespace in a conditional/loop construct.\r
+Returns some position at the last line."\r
+ (interactive)\r
+ (or end\r
+ (setq end (point-max)))\r
+ (let ((ee (save-excursion (end-of-line) (point)))\r
+ (cperl-indent-region-fix-constructs\r
+ (or cperl-indent-region-fix-constructs 1))\r
+ p pp ml have-brace ret)\r
+ (save-excursion\r
+ (beginning-of-line)\r
+ (setq ret (point))\r
+ ;; }? continue\r
+ ;; blah; }\r
+ (if (not\r
+ (or (looking-at "[ \t]*\\(els\\(e\\|if\\)\\|continue\\|if\\|while\\|for\\(each\\)?\\|until\\)")\r
+ (setq have-brace (save-excursion (search-forward "}" ee t)))))\r
+ nil ; Do not need to do anything\r
+ ;; Looking at:\r
+ ;; }\r
+ ;; else\r
+ (if (and cperl-merge-trailing-else\r
+ (looking-at\r
+ "[ \t]*}[ \t]*\n[ \t\n]*\\(els\\(e\\|if\\)\\|continue\\)\\>"))\r
+ (progn\r
+ (search-forward "}")\r
+ (setq p (point))\r
+ (skip-chars-forward " \t\n")\r
+ (delete-region p (point))\r
+ (insert (make-string cperl-indent-region-fix-constructs ?\ ))\r
+ (beginning-of-line)))\r
+ ;; Looking at:\r
+ ;; } else\r
+ (if (looking-at "[ \t]*}\\(\t*\\|[ \t][ \t]+\\)\\<\\(els\\(e\\|if\\)\\|continue\\)\\>")\r
+ (progn\r
+ (search-forward "}")\r
+ (delete-horizontal-space)\r
+ (insert (make-string cperl-indent-region-fix-constructs ?\ ))\r
+ (beginning-of-line)))\r
+ ;; Looking at:\r
+ ;; else {\r
+ (if (looking-at\r
+ "[ \t]*}?[ \t]*\\<\\(\\els\\(e\\|if\\)\\|continue\\|unless\\|if\\|while\\|for\\(each\\)?\\|until\\)\\>\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]")\r
+ (progn\r
+ (forward-word 1)\r
+ (delete-horizontal-space)\r
+ (insert (make-string cperl-indent-region-fix-constructs ?\ ))\r
+ (beginning-of-line)))\r
+ ;; Looking at:\r
+ ;; foreach my $var\r
+ (if (looking-at\r
+ "[ \t]*\\<for\\(each\\)?[ \t]+\\(my\\|local\\|our\\)\\(\t*\\|[ \t][ \t]+\\)[^ \t\n]")\r
+ (progn\r
+ (forward-word 2)\r
+ (delete-horizontal-space)\r
+ (insert (make-string cperl-indent-region-fix-constructs ?\ ))\r
+ (beginning-of-line)))\r
+ ;; Looking at:\r
+ ;; foreach my $var (\r
+ (if (looking-at\r
+ "[ \t]*\\<for\\(each\\)?[ \t]+\\(my\\|local\\|our\\)[ \t]*\\$[_a-zA-Z0-9]+\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]")\r
+ (progn\r
+ (forward-sexp 3)\r
+ (delete-horizontal-space)\r
+ (insert\r
+ (make-string cperl-indent-region-fix-constructs ?\ ))\r
+ (beginning-of-line)))\r
+ ;; Looking at:\r
+ ;; } foreach my $var () {\r
+ (if (looking-at\r
+ "[ \t]*\\(}[ \t]*\\)?\\<\\(\\els\\(e\\|if\\)\\|continue\\|if\\|unless\\|while\\|for\\(each\\)?\\(\\([ \t]+\\(my\\|local\\|our\\)\\)?[ \t]*\\$[_a-zA-Z0-9]+\\)?\\|until\\)\\>\\([ \t]*(\\|[ \t\n]*{\\)\\|[ \t]*{")\r
+ (progn\r
+ (setq ml (match-beginning 8))\r
+ (re-search-forward "[({]")\r
+ (forward-char -1)\r
+ (setq p (point))\r
+ (if (eq (following-char) ?\( )\r
+ (progn\r
+ (forward-sexp 1)\r
+ (setq pp (point)))\r
+ ;; after `else' or nothing\r
+ (if ml ; after `else'\r
+ (skip-chars-backward " \t\n")\r
+ (beginning-of-line))\r
+ (setq pp nil))\r
+ ;; Now after the sexp before the brace\r
+ ;; Multiline expr should be special\r
+ (setq ml (and pp (save-excursion (goto-char p)\r
+ (search-forward "\n" pp t))))\r
+ (if (and (or (not pp) (< pp end))\r
+ (looking-at "[ \t\n]*{"))\r
+ (progn\r
+ (cond\r
+ ((bolp) ; Were before `{', no if/else/etc\r
+ nil)\r
+ ((looking-at "\\(\t*\\| [ \t]+\\){")\r
+ (delete-horizontal-space)\r
+ (if (if ml\r
+ cperl-extra-newline-before-brace-multiline\r
+ cperl-extra-newline-before-brace)\r
+ (progn\r
+ (delete-horizontal-space)\r
+ (insert "\n")\r
+ (setq ret (point))\r
+ (if (cperl-indent-line parse-data)\r
+ (progn\r
+ (cperl-fix-line-spacing end parse-data)\r
+ (setq ret (point)))))\r
+ (insert\r
+ (make-string cperl-indent-region-fix-constructs ?\ ))))\r
+ ((and (looking-at "[ \t]*\n")\r
+ (not (if ml\r
+ cperl-extra-newline-before-brace-multiline\r
+ cperl-extra-newline-before-brace)))\r
+ (setq pp (point))\r
+ (skip-chars-forward " \t\n")\r
+ (delete-region pp (point))\r
+ (insert\r
+ (make-string cperl-indent-region-fix-constructs ?\ ))))\r
+ ;; Now we are before `{'\r
+ (if (looking-at "[ \t\n]*{[ \t]*[^ \t\n#]")\r
+ (progn\r
+ (skip-chars-forward " \t\n")\r
+ (setq pp (point))\r
+ (forward-sexp 1)\r
+ (setq p (point))\r
+ (goto-char pp)\r
+ (setq ml (search-forward "\n" p t))\r
+ (if (or cperl-break-one-line-blocks-when-indent ml)\r
+ ;; not good: multi-line BLOCK\r
+ (progn\r
+ (goto-char (1+ pp))\r
+ (delete-horizontal-space)\r
+ (insert "\n")\r
+ (setq ret (point))\r
+ (if (cperl-indent-line parse-data)\r
+ (setq ret (cperl-fix-line-spacing end parse-data)))))))))))\r
+ (beginning-of-line)\r
+ (setq p (point) pp (save-excursion (end-of-line) (point))) ; May be different from ee.\r
+ ;; Now check whether there is a hanging `}'\r
+ ;; Looking at:\r
+ ;; } blah\r
+ (if (and\r
+ cperl-fix-hanging-brace-when-indent\r
+ have-brace\r
+ (not (looking-at "[ \t]*}[ \t]*\\(\\<\\(els\\(if\\|e\\)\\|continue\\|while\\|until\\)\\>\\|$\\|#\\)"))\r
+ (condition-case nil\r
+ (progn\r
+ (up-list 1)\r
+ (if (and (<= (point) pp)\r
+ (eq (preceding-char) ?\} )\r
+ (cperl-after-block-and-statement-beg (point-min)))\r
+ t\r
+ (goto-char p)\r
+ nil))\r
+ (error nil)))\r
+ (progn\r
+ (forward-char -1)\r
+ (skip-chars-backward " \t")\r
+ (if (bolp)\r
+ ;; `}' was the first thing on the line, insert NL *after* it.\r
+ (progn\r
+ (cperl-indent-line parse-data)\r
+ (search-forward "}")\r
+ (delete-horizontal-space)\r
+ (insert "\n"))\r
+ (delete-horizontal-space)\r
+ (or (eq (preceding-char) ?\;)\r
+ (bolp)\r
+ (and (eq (preceding-char) ?\} )\r
+ (cperl-after-block-p (point-min)))\r
+ (insert ";"))\r
+ (insert "\n")\r
+ (setq ret (point)))\r
+ (if (cperl-indent-line parse-data)\r
+ (setq ret (cperl-fix-line-spacing end parse-data)))\r
+ (beginning-of-line)))))\r
+ ret))\r
+\r
+(defvar cperl-update-start) ; Do not need to make them local\r
+(defvar cperl-update-end)\r
+(defun cperl-delay-update-hook (beg end old-len)\r
+ (setq cperl-update-start (min beg (or cperl-update-start (point-max))))\r
+ (setq cperl-update-end (max end (or cperl-update-end (point-min)))))\r
+\r
+(defun cperl-indent-region (start end)\r
+ "Simple variant of indentation of region in CPerl mode.\r
+Should be slow. Will not indent comment if it starts at `comment-indent'\r
+or looks like continuation of the comment on the previous line.\r
+Indents all the lines whose first character is between START and END\r
+inclusive.\r
+\r
+If `cperl-indent-region-fix-constructs', will improve spacing on\r
+conditional/loop constructs."\r
+ (interactive "r")\r
+ (cperl-update-syntaxification end end)\r
+ (save-excursion\r
+ (let (cperl-update-start cperl-update-end (h-a-c after-change-functions))\r
+ (let ((indent-info (if cperl-emacs-can-parse\r
+ (list nil nil nil) ; Cannot use '(), since will modify\r
+ nil))\r
+ (pm 0) (imenu-scanning-message "Indenting... (%3d%%)")\r
+ after-change-functions ; Speed it up!\r
+ st comm old-comm-indent new-comm-indent p pp i empty)\r
+ (if h-a-c (add-hook 'after-change-functions 'cperl-delay-update-hook))\r
+ (goto-char start)\r
+ (setq old-comm-indent (and (cperl-to-comment-or-eol)\r
+ (current-column))\r
+ new-comm-indent old-comm-indent)\r
+ (goto-char start)\r
+ (setq end (set-marker (make-marker) end)) ; indentation changes pos\r
+ (or (bolp) (beginning-of-line 2))\r
+ (or (fboundp 'imenu-progress-message)\r
+ (message "Indenting... For feedback load `imenu'..."))\r
+ (while (and (<= (point) end) (not (eobp))) ; bol to check start\r
+ (and (fboundp 'imenu-progress-message)\r
+ (imenu-progress-message\r
+ pm (/ (* 100 (- (point) start)) (- end start -1))))\r
+ (setq st (point))\r
+ (if (or\r
+ (setq empty (looking-at "[ \t]*\n"))\r
+ (and (setq comm (looking-at "[ \t]*#"))\r
+ (or (eq (current-indentation) (or old-comm-indent\r
+ comment-column))\r
+ (setq old-comm-indent nil))))\r
+ (if (and old-comm-indent\r
+ (not empty)\r
+ (= (current-indentation) old-comm-indent)\r
+ (not (eq (get-text-property (point) 'syntax-type) 'pod))\r
+ (not (eq (get-text-property (point) 'syntax-table)\r
+ cperl-st-cfence)))\r
+ (let ((comment-column new-comm-indent))\r
+ (indent-for-comment)))\r
+ (progn\r
+ (setq i (cperl-indent-line indent-info))\r
+ (or comm\r
+ (not i)\r
+ (progn\r
+ (if cperl-indent-region-fix-constructs\r
+ (goto-char (cperl-fix-line-spacing end indent-info)))\r
+ (if (setq old-comm-indent\r
+ (and (cperl-to-comment-or-eol)\r
+ (not (memq (get-text-property (point)\r
+ 'syntax-type)\r
+ '(pod here-doc)))\r
+ (not (eq (get-text-property (point)\r
+ 'syntax-table)\r
+ cperl-st-cfence))\r
+ (current-column)))\r
+ (progn (indent-for-comment)\r
+ (skip-chars-backward " \t")\r
+ (skip-chars-backward "#")\r
+ (setq new-comm-indent (current-column))))))))\r
+ (beginning-of-line 2))\r
+ (if (fboundp 'imenu-progress-message)\r
+ (imenu-progress-message pm 100)\r
+ (message nil)))\r
+ ;; Now run the update hooks\r
+ (and after-change-functions\r
+ cperl-update-end\r
+ (save-excursion\r
+ (goto-char cperl-update-end)\r
+ (insert " ")\r
+ (delete-char -1)\r
+ (goto-char cperl-update-start)\r
+ (insert " ")\r
+ (delete-char -1))))))\r
+\r
+;; Stolen from lisp-mode with a lot of improvements\r
+\r
+(defun cperl-fill-paragraph (&optional justify iteration)\r
+ "Like \\[fill-paragraph], but handle CPerl comments.\r
+If any of the current line is a comment, fill the comment or the\r
+block of it that point is in, preserving the comment's initial\r
+indentation and initial hashes. Behaves usually outside of comment."\r
+ (interactive "P")\r
+ (let (;; Non-nil if the current line contains a comment.\r
+ has-comment\r
+\r
+ ;; If has-comment, the appropriate fill-prefix for the comment.\r
+ comment-fill-prefix\r
+ ;; Line that contains code and comment (or nil)\r
+ start\r
+ c spaces len dc (comment-column comment-column))\r
+ ;; Figure out what kind of comment we are looking at.\r
+ (save-excursion\r
+ (beginning-of-line)\r
+ (cond\r
+\r
+ ;; A line with nothing but a comment on it?\r
+ ((looking-at "[ \t]*#[# \t]*")\r
+ (setq has-comment t\r
+ comment-fill-prefix (buffer-substring (match-beginning 0)\r
+ (match-end 0))))\r
+\r
+ ;; A line with some code, followed by a comment? Remember that the\r
+ ;; semi which starts the comment shouldn't be part of a string or\r
+ ;; character.\r
+ ((cperl-to-comment-or-eol)\r
+ (setq has-comment t)\r
+ (looking-at "#+[ \t]*")\r
+ (setq start (point) c (current-column)\r
+ comment-fill-prefix\r
+ (concat (make-string (current-column) ?\ )\r
+ (buffer-substring (match-beginning 0) (match-end 0)))\r
+ spaces (progn (skip-chars-backward " \t")\r
+ (buffer-substring (point) start))\r
+ dc (- c (current-column)) len (- start (point))\r
+ start (point-marker))\r
+ (delete-char len)\r
+ (insert (make-string dc ?-)))))\r
+ (if (not has-comment)\r
+ (fill-paragraph justify) ; Do the usual thing outside of comment\r
+ ;; Narrow to include only the comment, and then fill the region.\r
+ (save-restriction\r
+ (narrow-to-region\r
+ ;; Find the first line we should include in the region to fill.\r
+ (if start (progn (beginning-of-line) (point))\r
+ (save-excursion\r
+ (while (and (zerop (forward-line -1))\r
+ (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]")))\r
+ ;; We may have gone to far. Go forward again.\r
+ (or (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]")\r
+ (forward-line 1))\r
+ (point)))\r
+ ;; Find the beginning of the first line past the region to fill.\r
+ (save-excursion\r
+ (while (progn (forward-line 1)\r
+ (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]")))\r
+ (point)))\r
+ ;; Remove existing hashes\r
+ (goto-char (point-min))\r
+ (while (progn (forward-line 1) (< (point) (point-max)))\r
+ (skip-chars-forward " \t")\r
+ (and (looking-at "#+")\r
+ (delete-char (- (match-end 0) (match-beginning 0)))))\r
+\r
+ ;; Lines with only hashes on them can be paragraph boundaries.\r
+ (let ((paragraph-start (concat paragraph-start "\\|^[ \t#]*$"))\r
+ (paragraph-separate (concat paragraph-start "\\|^[ \t#]*$"))\r
+ (fill-prefix comment-fill-prefix))\r
+ (fill-paragraph justify)))\r
+ (if (and start)\r
+ (progn\r
+ (goto-char start)\r
+ (if (> dc 0)\r
+ (progn (delete-char dc) (insert spaces)))\r
+ (if (or (= (current-column) c) iteration) nil\r
+ (setq comment-column c)\r
+ (indent-for-comment)\r
+ ;; Repeat once more, flagging as iteration\r
+ (cperl-fill-paragraph justify t)))))))\r
+\r
+(defun cperl-do-auto-fill ()\r
+ ;; Break out if the line is short enough\r
+ (if (> (save-excursion\r
+ (end-of-line)\r
+ (current-column))\r
+ fill-column)\r
+ (let ((c (save-excursion (beginning-of-line)\r
+ (cperl-to-comment-or-eol) (point)))\r
+ (s (memq (following-char) '(?\ ?\t))) marker)\r
+ (if (>= c (point)) nil\r
+ (setq marker (point-marker))\r
+ (cperl-fill-paragraph)\r
+ (goto-char marker)\r
+ ;; Is not enough, sometimes marker is a start of line\r
+ (if (bolp) (progn (re-search-forward "#+[ \t]*")\r
+ (goto-char (match-end 0))))\r
+ ;; Following space could have gone:\r
+ (if (or (not s) (memq (following-char) '(?\ ?\t))) nil\r
+ (insert " ")\r
+ (backward-char 1))\r
+ ;; Previous space could have gone:\r
+ (or (memq (preceding-char) '(?\ ?\t)) (insert " "))))))\r
+\r
+(defun cperl-imenu-addback (lst &optional isback name)\r
+ ;; We suppose that the lst is a DAG, unless the first element only\r
+ ;; loops back, and ISBACK is set. Thus this function cannot be\r
+ ;; applied twice without ISBACK set.\r
+ (cond ((not cperl-imenu-addback) lst)\r
+ (t\r
+ (or name\r
+ (setq name "+++BACK+++"))\r
+ (mapcar (lambda (elt)\r
+ (if (and (listp elt) (listp (cdr elt)))\r
+ (progn\r
+ ;; In the other order it goes up\r
+ ;; one level only ;-(\r
+ (setcdr elt (cons (cons name lst)\r
+ (cdr elt)))\r
+ (cperl-imenu-addback (cdr elt) t name))))\r
+ (if isback (cdr lst) lst))\r
+ lst)))\r
+\r
+(defun cperl-imenu--create-perl-index (&optional regexp)\r
+ (require 'cl)\r
+ (require 'imenu) ; May be called from TAGS creator\r
+ (let ((index-alist '()) (index-pack-alist '()) (index-pod-alist '())\r
+ (index-unsorted-alist '()) (i-s-f (default-value 'imenu-sort-function))\r
+ (index-meth-alist '()) meth\r
+ packages ends-ranges p marker\r
+ (prev-pos 0) char fchar index index1 name (end-range 0) package)\r
+ (goto-char (point-min))\r
+ (if noninteractive\r
+ (message "Scanning Perl for index")\r
+ (imenu-progress-message prev-pos 0))\r
+ (cperl-update-syntaxification (point-max) (point-max))\r
+ ;; Search for the function\r
+ (progn ;;save-match-data\r
+ (while (re-search-forward\r
+ (or regexp cperl-imenu--function-name-regexp-perl)\r
+ nil t)\r
+ (or noninteractive\r
+ (imenu-progress-message prev-pos))\r
+ (cond\r
+ ((and ; Skip some noise if building tags\r
+ (match-beginning 2) ; package or sub\r
+ (eq (char-after (match-beginning 2)) ?p) ; package\r
+ (not (save-match-data\r
+ (looking-at "[ \t\n]*;")))) ; Plain text word 'package'\r
+ nil)\r
+ ((and\r
+ (match-beginning 2) ; package or sub\r
+ ;; Skip if quoted (will not skip multi-line ''-strings :-():\r
+ (null (get-text-property (match-beginning 1) 'syntax-table))\r
+ (null (get-text-property (match-beginning 1) 'syntax-type))\r
+ (null (get-text-property (match-beginning 1) 'in-pod)))\r
+ (save-excursion\r
+ (goto-char (match-beginning 2))\r
+ (setq fchar (following-char)))\r
+ ;; (if (looking-at "([^()]*)[ \t\n\f]*")\r
+ ;; (goto-char (match-end 0))) ; Messes what follows\r
+ (setq char (following-char) ; ?\; for "sub foo () ;"\r
+ meth nil\r
+ p (point))\r
+ (while (and ends-ranges (>= p (car ends-ranges)))\r
+ ;; delete obsolete entries\r
+ (setq ends-ranges (cdr ends-ranges) packages (cdr packages)))\r
+ (setq package (or (car packages) "")\r
+ end-range (or (car ends-ranges) 0))\r
+ (if (eq fchar ?p)\r
+ (setq name (buffer-substring (match-beginning 3) (match-end 3))\r
+ name (progn\r
+ (set-text-properties 0 (length name) nil name)\r
+ name)\r
+ package (concat name "::")\r
+ name (concat "package " name)\r
+ end-range\r
+ (save-excursion\r
+ (parse-partial-sexp (point) (point-max) -1) (point))\r
+ ends-ranges (cons end-range ends-ranges)\r
+ packages (cons package packages)))\r
+ ;; )\r
+ ;; Skip this function name if it is a prototype declaration.\r
+ (if (and (eq fchar ?s) (eq char ?\;)) nil\r
+ (setq name (buffer-substring (match-beginning 3) (match-end 3))\r
+ marker (make-marker))\r
+ (set-text-properties 0 (length name) nil name)\r
+ (set-marker marker (match-end 3))\r
+ (if (eq fchar ?p)\r
+ (setq name (concat "package " name))\r
+ (cond ((string-match "[:']" name)\r
+ (setq meth t))\r
+ ((> p end-range) nil)\r
+ (t\r
+ (setq name (concat package name) meth t))))\r
+ (setq index (cons name marker))\r
+ (if (eq fchar ?p)\r
+ (push index index-pack-alist)\r
+ (push index index-alist))\r
+ (if meth (push index index-meth-alist))\r
+ (push index index-unsorted-alist)))\r
+ ((match-beginning 5) ; POD section\r
+ ;; (beginning-of-line)\r
+ (setq index (imenu-example--name-and-position)\r
+ name (buffer-substring (match-beginning 6) (match-end 6)))\r
+ (set-text-properties 0 (length name) nil name)\r
+ (if (eq (char-after (match-beginning 5)) ?2)\r
+ (setq name (concat " " name)))\r
+ (setcar index name)\r
+ (setq index1 (cons (concat "=" name) (cdr index)))\r
+ (push index index-pod-alist)\r
+ (push index1 index-unsorted-alist)))))\r
+ (or noninteractive\r
+ (imenu-progress-message prev-pos 100))\r
+ (setq index-alist\r
+ (if (default-value 'imenu-sort-function)\r
+ (sort index-alist (default-value 'imenu-sort-function))\r
+ (nreverse index-alist)))\r
+ (and index-pod-alist\r
+ (push (cons "+POD headers+..."\r
+ (nreverse index-pod-alist))\r
+ index-alist))\r
+ (and (or index-pack-alist index-meth-alist)\r
+ (let ((lst index-pack-alist) hier-list pack elt group name)\r
+ ;; Remove "package ", reverse and uniquify.\r
+ (while lst\r
+ (setq elt (car lst) lst (cdr lst) name (substring (car elt) 8))\r
+ (if (assoc name hier-list) nil\r
+ (setq hier-list (cons (cons name (cdr elt)) hier-list))))\r
+ (setq lst index-meth-alist)\r
+ (while lst\r
+ (setq elt (car lst) lst (cdr lst))\r
+ (cond ((string-match "\\(::\\|'\\)[_a-zA-Z0-9]+$" (car elt))\r
+ (setq pack (substring (car elt) 0 (match-beginning 0)))\r
+ (if (setq group (assoc pack hier-list))\r
+ (if (listp (cdr group))\r
+ ;; Have some functions already\r
+ (setcdr group\r
+ (cons (cons (substring\r
+ (car elt)\r
+ (+ 2 (match-beginning 0)))\r
+ (cdr elt))\r
+ (cdr group)))\r
+ (setcdr group (list (cons (substring\r
+ (car elt)\r
+ (+ 2 (match-beginning 0)))\r
+ (cdr elt)))))\r
+ (setq hier-list\r
+ (cons (cons pack\r
+ (list (cons (substring\r
+ (car elt)\r
+ (+ 2 (match-beginning 0)))\r
+ (cdr elt))))\r
+ hier-list))))))\r
+ (push (cons "+Hierarchy+..."\r
+ hier-list)\r
+ index-alist)))\r
+ (and index-pack-alist\r
+ (push (cons "+Packages+..."\r
+ (nreverse index-pack-alist))\r
+ index-alist))\r
+ (and (or index-pack-alist index-pod-alist\r
+ (default-value 'imenu-sort-function))\r
+ index-unsorted-alist\r
+ (push (cons "+Unsorted List+..."\r
+ (nreverse index-unsorted-alist))\r
+ index-alist))\r
+ (cperl-imenu-addback index-alist)))\r
+\r
+\f\r
+;; Suggested by Mark A. Hershberger\r
+(defun cperl-outline-level ()\r
+ (looking-at outline-regexp)\r
+ (cond ((not (match-beginning 1)) 0) ; beginning-of-file\r
+ ((match-beginning 2)\r
+ (if (eq (char-after (match-beginning 2)) ?p)\r
+ 0 ; package\r
+ 1)) ; sub\r
+ ((match-beginning 5)\r
+ (if (eq (char-after (match-beginning 5)) ?1)\r
+ 1 ; head1\r
+ 2)) ; head2\r
+ (t 3))) ; should not happen\r
+\r
+\f\r
+(defvar cperl-compilation-error-regexp-alist\r
+ ;; This look like a paranoiac regexp: could anybody find a better one? (which WORK).\r
+ '(("^[^\n]* \\(file\\|at\\) \\([^ \t\n]+\\) [^\n]*line \\([0-9]+\\)[\\., \n]"\r
+ 2 3))\r
+ "Alist that specifies how to match errors in perl output.")\r
+\r
+(if (fboundp 'eval-after-load)\r
+ (eval-after-load\r
+ "mode-compile"\r
+ '(setq perl-compilation-error-regexp-alist\r
+ cperl-compilation-error-regexp-alist)))\r
+\r
+\r
+(defun cperl-windowed-init ()\r
+ "Initialization under windowed version."\r
+ (if (or (featurep 'ps-print) cperl-faces-init)\r
+ ;; Need to init anyway:\r
+ (or cperl-faces-init (cperl-init-faces))\r
+ (add-hook 'font-lock-mode-hook\r
+ (function\r
+ (lambda ()\r
+ (if (memq major-mode '(perl-mode cperl-mode))\r
+ (progn\r
+ (or cperl-faces-init (cperl-init-faces)))))))\r
+ (if (fboundp 'eval-after-load)\r
+ (eval-after-load\r
+ "ps-print"\r
+ '(or cperl-faces-init (cperl-init-faces))))))\r
+\r
+(defun cperl-load-font-lock-keywords ()\r
+ (or cperl-faces-init (cperl-init-faces))\r
+ perl-font-lock-keywords)\r
+\r
+(defun cperl-load-font-lock-keywords-1 ()\r
+ (or cperl-faces-init (cperl-init-faces))\r
+ perl-font-lock-keywords-1)\r
+\r
+(defun cperl-load-font-lock-keywords-2 ()\r
+ (or cperl-faces-init (cperl-init-faces))\r
+ perl-font-lock-keywords-2)\r
+\r
+(defvar perl-font-lock-keywords-1 nil\r
+ "Additional expressions to highlight in Perl mode. Minimal set.")\r
+(defvar perl-font-lock-keywords nil\r
+ "Additional expressions to highlight in Perl mode. Default set.")\r
+(defvar perl-font-lock-keywords-2 nil\r
+ "Additional expressions to highlight in Perl mode. Maximal set")\r
+\r
+(defvar font-lock-background-mode)\r
+(defvar font-lock-display-type)\r
+(defun cperl-init-faces-weak ()\r
+ ;; Allow `cperl-find-pods-heres' to run.\r
+ (or (boundp 'font-lock-constant-face)\r
+ (cperl-force-face font-lock-constant-face\r
+ "Face for constant and label names")\r
+ ;;(setq font-lock-constant-face 'font-lock-constant-face)\r
+ ))\r
+\r
+(defun cperl-init-faces ()\r
+ (condition-case errs\r
+ (progn\r
+ (require 'font-lock)\r
+ (and (fboundp 'font-lock-fontify-anchored-keywords)\r
+ (featurep 'font-lock-extra)\r
+ (message "You have an obsolete package `font-lock-extra'. Install `choose-color'."))\r
+ (let (t-font-lock-keywords t-font-lock-keywords-1 font-lock-anchored)\r
+ (if (fboundp 'font-lock-fontify-anchored-keywords)\r
+ (setq font-lock-anchored t))\r
+ (setq\r
+ t-font-lock-keywords\r
+ (list\r
+ (list "[ \t]+$" 0 cperl-invalid-face t)\r
+ (cons\r
+ (concat\r
+ "\\(^\\|[^$@%&\\]\\)\\<\\("\r
+ (mapconcat\r
+ 'identity\r
+ '("if" "until" "while" "elsif" "else" "unless" "for"\r
+ "foreach" "continue" "exit" "die" "last" "goto" "next"\r
+ "redo" "return" "local" "exec" "sub" "do" "dump" "use"\r
+ "require" "package" "eval" "my" "BEGIN" "END" "CHECK" "INIT")\r
+ "\\|") ; Flow control\r
+ "\\)\\>") 2) ; was "\\)[ \n\t;():,\|&]"\r
+ ; In what follows we use `type' style\r
+ ; for overwritable builtins\r
+ (list\r
+ (concat\r
+ "\\(^\\|[^$@%&\\]\\)\\<\\("\r
+ ;; "CORE" "__FILE__" "__LINE__" "abs" "accept" "alarm"\r
+ ;; "and" "atan2" "bind" "binmode" "bless" "caller"\r
+ ;; "chdir" "chmod" "chown" "chr" "chroot" "close"\r
+ ;; "closedir" "cmp" "connect" "continue" "cos" "crypt"\r
+ ;; "dbmclose" "dbmopen" "die" "dump" "endgrent"\r
+ ;; "endhostent" "endnetent" "endprotoent" "endpwent"\r
+ ;; "endservent" "eof" "eq" "exec" "exit" "exp" "fcntl"\r
+ ;; "fileno" "flock" "fork" "formline" "ge" "getc"\r
+ ;; "getgrent" "getgrgid" "getgrnam" "gethostbyaddr"\r
+ ;; "gethostbyname" "gethostent" "getlogin"\r
+ ;; "getnetbyaddr" "getnetbyname" "getnetent"\r
+ ;; "getpeername" "getpgrp" "getppid" "getpriority"\r
+ ;; "getprotobyname" "getprotobynumber" "getprotoent"\r
+ ;; "getpwent" "getpwnam" "getpwuid" "getservbyname"\r
+ ;; "getservbyport" "getservent" "getsockname"\r
+ ;; "getsockopt" "glob" "gmtime" "gt" "hex" "index" "int"\r
+ ;; "ioctl" "join" "kill" "lc" "lcfirst" "le" "length"\r
+ ;; "link" "listen" "localtime" "lock" "log" "lstat" "lt"\r
+ ;; "mkdir" "msgctl" "msgget" "msgrcv" "msgsnd" "ne"\r
+ ;; "not" "oct" "open" "opendir" "or" "ord" "pack" "pipe"\r
+ ;; "quotemeta" "rand" "read" "readdir" "readline"\r
+ ;; "readlink" "readpipe" "recv" "ref" "rename" "require"\r
+ ;; "reset" "reverse" "rewinddir" "rindex" "rmdir" "seek"\r
+ ;; "seekdir" "select" "semctl" "semget" "semop" "send"\r
+ ;; "setgrent" "sethostent" "setnetent" "setpgrp"\r
+ ;; "setpriority" "setprotoent" "setpwent" "setservent"\r
+ ;; "setsockopt" "shmctl" "shmget" "shmread" "shmwrite"\r
+ ;; "shutdown" "sin" "sleep" "socket" "socketpair"\r
+ ;; "sprintf" "sqrt" "srand" "stat" "substr" "symlink"\r
+ ;; "syscall" "sysopen" "sysread" "system" "syswrite" "tell"\r
+ ;; "telldir" "time" "times" "truncate" "uc" "ucfirst"\r
+ ;; "umask" "unlink" "unpack" "utime" "values" "vec"\r
+ ;; "wait" "waitpid" "wantarray" "warn" "write" "x" "xor"\r
+ "a\\(bs\\|ccept\\|tan2\\|larm\\|nd\\)\\|"\r
+ "b\\(in\\(d\\|mode\\)\\|less\\)\\|"\r
+ "c\\(h\\(r\\(\\|oot\\)\\|dir\\|mod\\|own\\)\\|aller\\|rypt\\|"\r
+ "lose\\(\\|dir\\)\\|mp\\|o\\(s\\|n\\(tinue\\|nect\\)\\)\\)\\|"\r
+ "CORE\\|d\\(ie\\|bm\\(close\\|open\\)\\|ump\\)\\|"\r
+ "e\\(x\\(p\\|it\\|ec\\)\\|q\\|nd\\(p\\(rotoent\\|went\\)\\|"\r
+ "hostent\\|servent\\|netent\\|grent\\)\\|of\\)\\|"\r
+ "f\\(ileno\\|cntl\\|lock\\|or\\(k\\|mline\\)\\)\\|"\r
+ "g\\(t\\|lob\\|mtime\\|e\\(\\|t\\(p\\(pid\\|r\\(iority\\|"\r
+ "oto\\(byn\\(ame\\|umber\\)\\|ent\\)\\)\\|eername\\|w"\r
+ "\\(uid\\|ent\\|nam\\)\\|grp\\)\\|host\\(by\\(addr\\|name\\)\\|"\r
+ "ent\\)\\|s\\(erv\\(by\\(port\\|name\\)\\|ent\\)\\|"\r
+ "ock\\(name\\|opt\\)\\)\\|c\\|login\\|net\\(by\\(addr\\|name\\)\\|"\r
+ "ent\\)\\|gr\\(ent\\|nam\\|gid\\)\\)\\)\\)\\|"\r
+ "hex\\|i\\(n\\(t\\|dex\\)\\|octl\\)\\|join\\|kill\\|"\r
+ "l\\(i\\(sten\\|nk\\)\\|stat\\|c\\(\\|first\\)\\|t\\|e"\r
+ "\\(\\|ngth\\)\\|o\\(c\\(altime\\|k\\)\\|g\\)\\)\\|m\\(sg\\(rcv\\|snd\\|"\r
+ "ctl\\|get\\)\\|kdir\\)\\|n\\(e\\|ot\\)\\|o\\(pen\\(\\|dir\\)\\|"\r
+ "r\\(\\|d\\)\\|ct\\)\\|p\\(ipe\\|ack\\)\\|quotemeta\\|"\r
+ "r\\(index\\|and\\|mdir\\|e\\(quire\\|ad\\(pipe\\|\\|lin"\r
+ "\\(k\\|e\\)\\|dir\\)\\|set\\|cv\\|verse\\|f\\|winddir\\|name"\r
+ "\\)\\)\\|s\\(printf\\|qrt\\|rand\\|tat\\|ubstr\\|e\\(t\\(p\\(r"\r
+ "\\(iority\\|otoent\\)\\|went\\|grp\\)\\|hostent\\|s\\(ervent\\|"\r
+ "ockopt\\)\\|netent\\|grent\\)\\|ek\\(\\|dir\\)\\|lect\\|"\r
+ "m\\(ctl\\|op\\|get\\)\\|nd\\)\\|h\\(utdown\\|m\\(read\\|ctl\\|"\r
+ "write\\|get\\)\\)\\|y\\(s\\(read\\|call\\|open\\|tem\\|write\\)\\|"\r
+ "mlink\\)\\|in\\|leep\\|ocket\\(pair\\|\\)\\)\\|t\\(runcate\\|"\r
+ "ell\\(\\|dir\\)\\|ime\\(\\|s\\)\\)\\|u\\(c\\(\\|first\\)\\|"\r
+ "time\\|mask\\|n\\(pack\\|link\\)\\)\\|v\\(alues\\|ec\\)\\|"\r
+ "w\\(a\\(rn\\|it\\(pid\\|\\)\\|ntarray\\)\\|rite\\)\\|"\r
+ "x\\(\\|or\\)\\|__\\(FILE__\\|LINE__\\|PACKAGE__\\)"\r
+ "\\)\\>") 2 'font-lock-type-face)\r
+ ;; In what follows we use `other' style\r
+ ;; for nonoverwritable builtins\r
+ ;; Somehow 's', 'm' are not auto-generated???\r
+ (list\r
+ (concat\r
+ "\\(^\\|[^$@%&\\]\\)\\<\\("\r
+ ;; "AUTOLOAD" "BEGIN" "CHECK" "DESTROY" "END" "INIT" "__END__" "chomp"\r
+ ;; "chop" "defined" "delete" "do" "each" "else" "elsif"\r
+ ;; "eval" "exists" "for" "foreach" "format" "goto"\r
+ ;; "grep" "if" "keys" "last" "local" "map" "my" "next"\r
+ ;; "no" "package" "pop" "pos" "print" "printf" "push"\r
+ ;; "q" "qq" "qw" "qx" "redo" "return" "scalar" "shift"\r
+ ;; "sort" "splice" "split" "study" "sub" "tie" "tr"\r
+ ;; "undef" "unless" "unshift" "untie" "until" "use"\r
+ ;; "while" "y"\r
+ "AUTOLOAD\\|BEGIN\\|CHECK\\|cho\\(p\\|mp\\)\\|d\\(e\\(fined\\|lete\\)\\|"\r
+ "o\\)\\|DESTROY\\|e\\(ach\\|val\\|xists\\|ls\\(e\\|if\\)\\)\\|"\r
+ "END\\|for\\(\\|each\\|mat\\)\\|g\\(rep\\|oto\\)\\|INIT\\|if\\|keys\\|"\r
+ "l\\(ast\\|ocal\\)\\|m\\(ap\\|y\\)\\|n\\(ext\\|o\\)\\|our\\|"\r
+ "p\\(ackage\\|rint\\(\\|f\\)\\|ush\\|o\\(p\\|s\\)\\)\\|"\r
+ "q\\(\\|q\\|w\\|x\\|r\\)\\|re\\(turn\\|do\\)\\|s\\(pli\\(ce\\|t\\)\\|"\r
+ "calar\\|tudy\\|ub\\|hift\\|ort\\)\\|t\\(r\\|ie\\)\\|"\r
+ "u\\(se\\|n\\(shift\\|ti\\(l\\|e\\)\\|def\\|less\\)\\)\\|"\r
+ "while\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually\r
+ "\\|[sm]" ; Added manually\r
+ "\\)\\>") 2 'cperl-nonoverridable-face)\r
+ ;; (mapconcat 'identity\r
+ ;; '("#endif" "#else" "#ifdef" "#ifndef" "#if"\r
+ ;; "#include" "#define" "#undef")\r
+ ;; "\\|")\r
+ '("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0\r
+ font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]"\r
+ '("\\<sub[ \t]+\\([^ \t{;()]+\\)[ \t]*\\(([^()]*)[ \t]*\\)?[#{\n]" 1\r
+ font-lock-function-name-face)\r
+ '("\\<\\(package\\|require\\|use\\|import\\|no\\|bootstrap\\)[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t;]" ; require A if B;\r
+ 2 font-lock-function-name-face)\r
+ '("^[ \t]*format[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t]*=[ \t]*$"\r
+ 1 font-lock-function-name-face)\r
+ (cond ((featurep 'font-lock-extra)\r
+ '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"\r
+ (2 font-lock-string-face t)\r
+ (0 '(restart 2 t)))) ; To highlight $a{bc}{ef}\r
+ (font-lock-anchored\r
+ '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"\r
+ (2 font-lock-string-face t)\r
+ ("\\=[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"\r
+ nil nil\r
+ (1 font-lock-string-face t))))\r
+ (t '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"\r
+ 2 font-lock-string-face t)))\r
+ '("[\[ \t{,(]\\(-?[a-zA-Z0-9_:]+\\)[ \t]*=>" 1\r
+ font-lock-string-face t)\r
+ '("^[ \t]*\\([a-zA-Z0-9_]+[ \t]*:\\)[ \t]*\\($\\|{\\|\\<\\(until\\|while\\|for\\(each\\)?\\|do\\)\\>\\)" 1\r
+ font-lock-constant-face) ; labels\r
+ '("\\<\\(continue\\|next\\|last\\|redo\\|goto\\)\\>[ \t]+\\([a-zA-Z0-9_:]+\\)" ; labels as targets\r
+ 2 font-lock-constant-face)\r
+ ;; Uncomment to get perl-mode-like vars\r
+ ;;; '("[$*]{?\\(\\sw+\\)" 1 font-lock-variable-name-face)\r
+ ;;; '("\\([@%]\\|\\$#\\)\\(\\sw+\\)"\r
+ ;;; (2 (cons font-lock-variable-name-face '(underline))))\r
+ (cond ((featurep 'font-lock-extra)\r
+ '("^[ \t]*\\(my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?"\r
+ (3 font-lock-variable-name-face)\r
+ (4 '(another 4 nil\r
+ ("\\=[ \t]*,[ \t]*\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?"\r
+ (1 font-lock-variable-name-face)\r
+ (2 '(restart 2 nil) nil t)))\r
+ nil t))) ; local variables, multiple\r
+ (font-lock-anchored\r
+ '("^[ \t{}]*\\(my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)"\r
+ (3 font-lock-variable-name-face)\r
+ ("\\=[ \t]*,[ \t]*\\([$@%*][a-zA-Z0-9_:]+\\)"\r
+ nil nil\r
+ (1 font-lock-variable-name-face))))\r
+ (t '("^[ \t{}]*\\(my\\|local\\our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)"\r
+ 3 font-lock-variable-name-face)))\r
+ '("\\<for\\(each\\)?\\([ \t]+\\(my\\|local\\|our\\)\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*("\r
+ 4 font-lock-variable-name-face)))\r
+ (setq\r
+ t-font-lock-keywords-1\r
+ (and (fboundp 'turn-on-font-lock) ; Check for newer font-lock\r
+ (not cperl-xemacs-p) ; not yet as of XEmacs 19.12\r
+ '(\r
+ ("\\(\\([@%]\\|\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1\r
+ (if (eq (char-after (match-beginning 2)) ?%)\r
+ cperl-hash-face\r
+ cperl-array-face)\r
+ t) ; arrays and hashes\r
+ ("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)"\r
+ 1\r
+ (if (= (- (match-end 2) (match-beginning 2)) 1)\r
+ (if (eq (char-after (match-beginning 3)) ?{)\r
+ cperl-hash-face\r
+ cperl-array-face) ; arrays and hashes\r
+ font-lock-variable-name-face) ; Just to put something\r
+ t)\r
+ ;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2")\r
+ ;;; Too much noise from \s* @s[ and friends\r
+ ;;("\\(\\<\\([msy]\\|tr\\)[ \t]*\\([^ \t\na-zA-Z0-9_]\\)\\|\\(/\\)\\)"\r
+ ;;(3 font-lock-function-name-face t t)\r
+ ;;(4\r
+ ;; (if (cperl-slash-is-regexp)\r
+ ;; font-lock-function-name-face 'default) nil t))\r
+ )))\r
+ (if cperl-highlight-variables-indiscriminately\r
+ (setq t-font-lock-keywords-1\r
+ (append t-font-lock-keywords-1\r
+ (list '("[$*]{?\\(\\sw+\\)" 1\r
+ font-lock-variable-name-face)))))\r
+ (setq perl-font-lock-keywords-1 \r
+ (if cperl-syntaxify-by-font-lock\r
+ (cons 'cperl-fontify-update\r
+ t-font-lock-keywords)\r
+ t-font-lock-keywords)\r
+ perl-font-lock-keywords perl-font-lock-keywords-1\r
+ perl-font-lock-keywords-2 (append\r
+ perl-font-lock-keywords-1\r
+ t-font-lock-keywords-1)))\r
+ (if (fboundp 'ps-print-buffer) (cperl-ps-print-init))\r
+ (if (or (featurep 'choose-color) (featurep 'font-lock-extra))\r
+ (eval ; Avoid a warning\r
+ '(font-lock-require-faces\r
+ (list\r
+ ;; Color-light Color-dark Gray-light Gray-dark Mono\r
+ (list 'font-lock-comment-face\r
+ ["Firebrick" "OrangeRed" "DimGray" "Gray80"]\r
+ nil\r
+ [nil nil t t t]\r
+ [nil nil t t t]\r
+ nil)\r
+ (list 'font-lock-string-face\r
+ ["RosyBrown" "LightSalmon" "Gray50" "LightGray"]\r
+ nil\r
+ nil\r
+ [nil nil t t t]\r
+ nil)\r
+ (list 'font-lock-function-name-face\r
+ (vector\r
+ "Blue" "LightSkyBlue" "Gray50" "LightGray"\r
+ (cdr (assq 'background-color ; if mono\r
+ (frame-parameters))))\r
+ (vector\r
+ nil nil nil nil\r
+ (cdr (assq 'foreground-color ; if mono\r
+ (frame-parameters))))\r
+ [nil nil t t t]\r
+ nil\r
+ nil)\r
+ (list 'font-lock-variable-name-face\r
+ ["DarkGoldenrod" "LightGoldenrod" "DimGray" "Gray90"]\r
+ nil\r
+ [nil nil t t t]\r
+ [nil nil t t t]\r
+ nil)\r
+ (list 'font-lock-type-face\r
+ ["DarkOliveGreen" "PaleGreen" "DimGray" "Gray80"]\r
+ nil\r
+ [nil nil t t t]\r
+ nil\r
+ [nil nil t t t])\r
+ (list 'font-lock-constant-face\r
+ ["CadetBlue" "Aquamarine" "Gray50" "LightGray"]\r
+ nil\r
+ [nil nil t t t]\r
+ nil\r
+ [nil nil t t t])\r
+ (list 'cperl-nonoverridable-face\r
+ ["chartreuse3" ("orchid1" "orange")\r
+ nil "Gray80"]\r
+ [nil nil "gray90"]\r
+ [nil nil nil t t]\r
+ [nil nil t t]\r
+ [nil nil t t t])\r
+ (list 'cperl-array-face\r
+ ["blue" "yellow" nil "Gray80"]\r
+ ["lightyellow2" ("navy" "os2blue" "darkgreen")\r
+ "gray90"]\r
+ t\r
+ nil\r
+ nil)\r
+ (list 'cperl-hash-face\r
+ ["red" "red" nil "Gray80"]\r
+ ["lightyellow2" ("navy" "os2blue" "darkgreen")\r
+ "gray90"]\r
+ t\r
+ t\r
+ nil))))\r
+ ;; Do it the dull way, without choose-color\r
+ (defvar cperl-guessed-background nil\r
+ "Display characteristics as guessed by cperl.")\r
+ ;; (or (fboundp 'x-color-defined-p)\r
+ ;; (defalias 'x-color-defined-p \r
+ ;; (cond ((fboundp 'color-defined-p) 'color-defined-p)\r
+ ;; ;; XEmacs >= 19.12\r
+ ;; ((fboundp 'valid-color-name-p) 'valid-color-name-p)\r
+ ;; ;; XEmacs 19.11\r
+ ;; (t 'x-valid-color-name-p))))\r
+ (cperl-force-face font-lock-constant-face\r
+ "Face for constant and label names")\r
+ (cperl-force-face font-lock-variable-name-face\r
+ "Face for variable names")\r
+ (cperl-force-face font-lock-type-face\r
+ "Face for data types")\r
+ (cperl-force-face cperl-nonoverridable-face\r
+ "Face for data types from another group")\r
+ (cperl-force-face font-lock-comment-face\r
+ "Face for comments")\r
+ (cperl-force-face font-lock-function-name-face\r
+ "Face for function names")\r
+ (cperl-force-face cperl-hash-face\r
+ "Face for hashes")\r
+ (cperl-force-face cperl-array-face\r
+ "Face for arrays")\r
+ ;;(defvar font-lock-constant-face 'font-lock-constant-face)\r
+ ;;(defvar font-lock-variable-name-face 'font-lock-variable-name-face)\r
+ ;;(or (boundp 'font-lock-type-face)\r
+ ;; (defconst font-lock-type-face\r
+ ;; 'font-lock-type-face\r
+ ;; "Face to use for data types."))\r
+ ;;(or (boundp 'cperl-nonoverridable-face)\r
+ ;; (defconst cperl-nonoverridable-face\r
+ ;; 'cperl-nonoverridable-face\r
+ ;; "Face to use for data types from another group."))\r
+ ;;(if (not cperl-xemacs-p) nil\r
+ ;; (or (boundp 'font-lock-comment-face)\r
+ ;; (defconst font-lock-comment-face\r
+ ;; 'font-lock-comment-face\r
+ ;; "Face to use for comments."))\r
+ ;; (or (boundp 'font-lock-keyword-face)\r
+ ;; (defconst font-lock-keyword-face\r
+ ;; 'font-lock-keyword-face\r
+ ;; "Face to use for keywords."))\r
+ ;; (or (boundp 'font-lock-function-name-face)\r
+ ;; (defconst font-lock-function-name-face\r
+ ;; 'font-lock-function-name-face\r
+ ;; "Face to use for function names.")))\r
+ (if (and\r
+ (not (cperl-is-face 'cperl-array-face))\r
+ (cperl-is-face 'font-lock-emphasized-face))\r
+ (copy-face 'font-lock-emphasized-face 'cperl-array-face))\r
+ (if (and\r
+ (not (cperl-is-face 'cperl-hash-face))\r
+ (cperl-is-face 'font-lock-other-emphasized-face))\r
+ (copy-face 'font-lock-other-emphasized-face\r
+ 'cperl-hash-face))\r
+ (if (and\r
+ (not (cperl-is-face 'cperl-nonoverridable-face))\r
+ (cperl-is-face 'font-lock-other-type-face))\r
+ (copy-face 'font-lock-other-type-face\r
+ 'cperl-nonoverridable-face))\r
+ ;;(or (boundp 'cperl-hash-face)\r
+ ;; (defconst cperl-hash-face\r
+ ;; 'cperl-hash-face\r
+ ;; "Face to use for hashes."))\r
+ ;;(or (boundp 'cperl-array-face)\r
+ ;; (defconst cperl-array-face\r
+ ;; 'cperl-array-face\r
+ ;; "Face to use for arrays."))\r
+ ;; Here we try to guess background\r
+ (let ((background\r
+ (if (boundp 'font-lock-background-mode)\r
+ font-lock-background-mode\r
+ 'light))\r
+ (face-list (and (fboundp 'face-list) (face-list))))\r
+;;;; (fset 'cperl-is-face\r
+;;;; (cond ((fboundp 'find-face)\r
+;;;; (symbol-function 'find-face))\r
+;;;; (face-list\r
+;;;; (function (lambda (face) (member face face-list))))\r
+;;;; (t\r
+;;;; (function (lambda (face) (boundp face))))))\r
+ (defvar cperl-guessed-background\r
+ (if (and (boundp 'font-lock-display-type)\r
+ (eq font-lock-display-type 'grayscale))\r
+ 'gray\r
+ background)\r
+ "Background as guessed by CPerl mode")\r
+ (and (not (cperl-is-face 'font-lock-constant-face))\r
+ (cperl-is-face 'font-lock-reference-face)\r
+ (copy-face 'font-lock-reference-face 'font-lock-constant-face))\r
+ (if (cperl-is-face 'font-lock-type-face) nil\r
+ (copy-face 'default 'font-lock-type-face)\r
+ (cond\r
+ ((eq background 'light)\r
+ (set-face-foreground 'font-lock-type-face\r
+ (if (x-color-defined-p "seagreen")\r
+ "seagreen"\r
+ "sea green")))\r
+ ((eq background 'dark)\r
+ (set-face-foreground 'font-lock-type-face\r
+ (if (x-color-defined-p "os2pink")\r
+ "os2pink"\r
+ "pink")))\r
+ (t\r
+ (set-face-background 'font-lock-type-face "gray90"))))\r
+ (if (cperl-is-face 'cperl-nonoverridable-face)\r
+ nil\r
+ (copy-face 'font-lock-type-face 'cperl-nonoverridable-face)\r
+ (cond\r
+ ((eq background 'light)\r
+ (set-face-foreground 'cperl-nonoverridable-face\r
+ (if (x-color-defined-p "chartreuse3")\r
+ "chartreuse3"\r
+ "chartreuse")))\r
+ ((eq background 'dark)\r
+ (set-face-foreground 'cperl-nonoverridable-face\r
+ (if (x-color-defined-p "orchid1")\r
+ "orchid1"\r
+ "orange")))))\r
+;;; (if (cperl-is-face 'font-lock-other-emphasized-face) nil\r
+;;; (copy-face 'bold-italic 'font-lock-other-emphasized-face)\r
+;;; (cond\r
+;;; ((eq background 'light)\r
+;;; (set-face-background 'font-lock-other-emphasized-face\r
+;;; (if (x-color-defined-p "lightyellow2")\r
+;;; "lightyellow2"\r
+;;; (if (x-color-defined-p "lightyellow")\r
+;;; "lightyellow"\r
+;;; "light yellow"))))\r
+;;; ((eq background 'dark)\r
+;;; (set-face-background 'font-lock-other-emphasized-face\r
+;;; (if (x-color-defined-p "navy")\r
+;;; "navy"\r
+;;; (if (x-color-defined-p "darkgreen")\r
+;;; "darkgreen"\r
+;;; "dark green"))))\r
+;;; (t (set-face-background 'font-lock-other-emphasized-face "gray90"))))\r
+;;; (if (cperl-is-face 'font-lock-emphasized-face) nil\r
+;;; (copy-face 'bold 'font-lock-emphasized-face)\r
+;;; (cond\r
+;;; ((eq background 'light)\r
+;;; (set-face-background 'font-lock-emphasized-face\r
+;;; (if (x-color-defined-p "lightyellow2")\r
+;;; "lightyellow2"\r
+;;; "lightyellow")))\r
+;;; ((eq background 'dark)\r
+;;; (set-face-background 'font-lock-emphasized-face\r
+;;; (if (x-color-defined-p "navy")\r
+;;; "navy"\r
+;;; (if (x-color-defined-p "darkgreen")\r
+;;; "darkgreen"\r
+;;; "dark green"))))\r
+;;; (t (set-face-background 'font-lock-emphasized-face "gray90"))))\r
+ (if (cperl-is-face 'font-lock-variable-name-face) nil\r
+ (copy-face 'italic 'font-lock-variable-name-face))\r
+ (if (cperl-is-face 'font-lock-constant-face) nil\r
+ (copy-face 'italic 'font-lock-constant-face))))\r
+ (setq cperl-faces-init t))\r
+ (error (message "cperl-init-faces (ignored): %s" errs))))\r
+\r
+\r
+(defun cperl-ps-print-init ()\r
+ "Initialization of `ps-print' components for faces used in CPerl."\r
+ (eval-after-load "ps-print"\r
+ '(setq ps-bold-faces\r
+ ;; font-lock-variable-name-face\r
+ ;; font-lock-constant-face\r
+ (append '(cperl-array-face\r
+ cperl-hash-face)\r
+ ps-bold-faces)\r
+ ps-italic-faces\r
+ ;; font-lock-constant-face\r
+ (append '(cperl-nonoverridable-face\r
+ cperl-hash-face)\r
+ ps-italic-faces)\r
+ ps-underlined-faces\r
+ ;; font-lock-type-face\r
+ (append '(cperl-array-face\r
+ cperl-hash-face\r
+ underline\r
+ cperl-nonoverridable-face)\r
+ ps-underlined-faces))))\r
+\r
+(defvar ps-print-face-extension-alist)\r
+\r
+(defun cperl-ps-print (&optional file)\r
+ "Pretty-print in CPerl style.\r
+If optional argument FILE is an empty string, prints to printer, otherwise\r
+to the file FILE. If FILE is nil, prompts for a file name.\r
+\r
+Style of printout regulated by the variable `cperl-ps-print-face-properties'."\r
+ (interactive)\r
+ (or file\r
+ (setq file (read-from-minibuffer\r
+ "Print to file (if empty - to printer): "\r
+ (concat (buffer-file-name) ".ps")\r
+ nil nil 'file-name-history)))\r
+ (or (> (length file) 0)\r
+ (setq file nil))\r
+ (require 'ps-print) ; To get ps-print-face-extension-alist\r
+ (let ((ps-print-color-p t)\r
+ (ps-print-face-extension-alist ps-print-face-extension-alist))\r
+ (cperl-ps-extend-face-list cperl-ps-print-face-properties)\r
+ (ps-print-buffer-with-faces file)))\r
+\r
+;;; (defun cperl-ps-print-init ()\r
+;;; "Initialization of `ps-print' components for faces used in CPerl."\r
+;;; ;; Guard against old versions\r
+;;; (defvar ps-underlined-faces nil)\r
+;;; (defvar ps-bold-faces nil)\r
+;;; (defvar ps-italic-faces nil)\r
+;;; (setq ps-bold-faces\r
+;;; (append '(font-lock-emphasized-face\r
+;;; cperl-array-face\r
+;;; font-lock-keyword-face\r
+;;; font-lock-variable-name-face\r
+;;; font-lock-constant-face\r
+;;; font-lock-reference-face\r
+;;; font-lock-other-emphasized-face\r
+;;; cperl-hash-face)\r
+;;; ps-bold-faces))\r
+;;; (setq ps-italic-faces\r
+;;; (append '(cperl-nonoverridable-face\r
+;;; font-lock-constant-face\r
+;;; font-lock-reference-face\r
+;;; font-lock-other-emphasized-face\r
+;;; cperl-hash-face)\r
+;;; ps-italic-faces))\r
+;;; (setq ps-underlined-faces\r
+;;; (append '(font-lock-emphasized-face\r
+;;; cperl-array-face\r
+;;; font-lock-other-emphasized-face\r
+;;; cperl-hash-face\r
+;;; cperl-nonoverridable-face font-lock-type-face)\r
+;;; ps-underlined-faces))\r
+;;; (cons 'font-lock-type-face ps-underlined-faces))\r
+\r
+\r
+(if (cperl-enable-font-lock) (cperl-windowed-init))\r
+\r
+(defconst cperl-styles-entries\r
+ '(cperl-indent-level cperl-brace-offset cperl-continued-brace-offset\r
+ cperl-label-offset cperl-extra-newline-before-brace\r
+ cperl-merge-trailing-else\r
+ cperl-continued-statement-offset))\r
+\r
+(defconst cperl-style-alist\r
+ '(("CPerl" ; =GNU without extra-newline-before-brace\r
+ (cperl-indent-level . 2)\r
+ (cperl-brace-offset . 0)\r
+ (cperl-continued-brace-offset . 0)\r
+ (cperl-label-offset . -2)\r
+ (cperl-extra-newline-before-brace . nil)\r
+ (cperl-merge-trailing-else . t)\r
+ (cperl-continued-statement-offset . 2))\r
+ ("PerlStyle" ; CPerl with 4 as indent\r
+ (cperl-indent-level . 4)\r
+ (cperl-brace-offset . 0)\r
+ (cperl-continued-brace-offset . 0)\r
+ (cperl-label-offset . -4)\r
+ (cperl-extra-newline-before-brace . nil)\r
+ (cperl-merge-trailing-else . t)\r
+ (cperl-continued-statement-offset . 4))\r
+ ("GNU"\r
+ (cperl-indent-level . 2)\r
+ (cperl-brace-offset . 0)\r
+ (cperl-continued-brace-offset . 0)\r
+ (cperl-label-offset . -2)\r
+ (cperl-extra-newline-before-brace . t)\r
+ (cperl-merge-trailing-else . nil)\r
+ (cperl-continued-statement-offset . 2))\r
+ ("K&R"\r
+ (cperl-indent-level . 5)\r
+ (cperl-brace-offset . 0)\r
+ (cperl-continued-brace-offset . -5)\r
+ (cperl-label-offset . -5)\r
+ ;;(cperl-extra-newline-before-brace . nil) ; ???\r
+ (cperl-merge-trailing-else . nil)\r
+ (cperl-continued-statement-offset . 5))\r
+ ("BSD"\r
+ (cperl-indent-level . 4)\r
+ (cperl-brace-offset . 0)\r
+ (cperl-continued-brace-offset . -4)\r
+ (cperl-label-offset . -4)\r
+ ;;(cperl-extra-newline-before-brace . nil) ; ???\r
+ (cperl-continued-statement-offset . 4))\r
+ ("C++"\r
+ (cperl-indent-level . 4)\r
+ (cperl-brace-offset . 0)\r
+ (cperl-continued-brace-offset . -4)\r
+ (cperl-label-offset . -4)\r
+ (cperl-continued-statement-offset . 4)\r
+ (cperl-merge-trailing-else . nil)\r
+ (cperl-extra-newline-before-brace . t))\r
+ ("Current")\r
+ ("Whitesmith"\r
+ (cperl-indent-level . 4)\r
+ (cperl-brace-offset . 0)\r
+ (cperl-continued-brace-offset . 0)\r
+ (cperl-label-offset . -4)\r
+ ;;(cperl-extra-newline-before-brace . nil) ; ???\r
+ (cperl-continued-statement-offset . 4)))\r
+ "(Experimental) list of variables to set to get a particular indentation style.\r
+Should be used via `cperl-set-style' or via Perl menu.")\r
+\r
+(defun cperl-set-style (style)\r
+ "Set CPerl mode variables to use one of several different indentation styles.\r
+The arguments are a string representing the desired style.\r
+The list of styles is in `cperl-style-alist', available styles\r
+are GNU, K&R, BSD, C++ and Whitesmith.\r
+\r
+The current value of style is memorized (unless there is a memorized\r
+data already), may be restored by `cperl-set-style-back'.\r
+\r
+Chosing \"Current\" style will not change style, so this may be used for\r
+side-effect of memorizing only."\r
+ (interactive\r
+ (let ((list (mapcar (function (lambda (elt) (list (car elt)))) \r
+ cperl-style-alist)))\r
+ (list (completing-read "Enter style: " list nil 'insist))))\r
+ (or cperl-old-style\r
+ (setq cperl-old-style\r
+ (mapcar (function\r
+ (lambda (name)\r
+ (cons name (eval name))))\r
+ cperl-styles-entries)))\r
+ (let ((style (cdr (assoc style cperl-style-alist))) setting str sym)\r
+ (while style\r
+ (setq setting (car style) style (cdr style))\r
+ (set (car setting) (cdr setting)))))\r
+\r
+(defun cperl-set-style-back ()\r
+ "Restore a style memorised by `cperl-set-style'."\r
+ (interactive)\r
+ (or cperl-old-style (error "The style was not changed"))\r
+ (let (setting)\r
+ (while cperl-old-style\r
+ (setq setting (car cperl-old-style)\r
+ cperl-old-style (cdr cperl-old-style))\r
+ (set (car setting) (cdr setting)))))\r
+\r
+(defun cperl-check-syntax ()\r
+ (interactive)\r
+ (require 'mode-compile)\r
+ (let ((perl-dbg-flags (concat cperl-extra-perl-args " -wc")))\r
+ (eval '(mode-compile)))) ; Avoid a warning\r
+\r
+(defun cperl-info-buffer (type)\r
+ ;; Returns buffer with documentation. Creates if missing.\r
+ ;; If TYPE, this vars buffer.\r
+ ;; Special care is taken to not stomp over an existing info buffer\r
+ (let* ((bname (if type "*info-perl-var*" "*info-perl*"))\r
+ (info (get-buffer bname))\r
+ (oldbuf (get-buffer "*info*")))\r
+ (if info info\r
+ (save-window-excursion\r
+ ;; Get Info running\r
+ (require 'info)\r
+ (cond (oldbuf\r
+ (set-buffer oldbuf)\r
+ (rename-buffer "*info-perl-tmp*")))\r
+ (save-window-excursion\r
+ (info))\r
+ (Info-find-node cperl-info-page (if type "perlvar" "perlfunc"))\r
+ (set-buffer "*info*")\r
+ (rename-buffer bname)\r
+ (cond (oldbuf\r
+ (set-buffer "*info-perl-tmp*")\r
+ (rename-buffer "*info*")\r
+ (set-buffer bname)))\r
+ (make-local-variable 'window-min-height)\r
+ (setq window-min-height 2)\r
+ (current-buffer)))))\r
+\r
+(defun cperl-word-at-point (&optional p)\r
+ "Return the word at point or at P."\r
+ (save-excursion\r
+ (if p (goto-char p))\r
+ (or (cperl-word-at-point-hard)\r
+ (progn\r
+ (require 'etags)\r
+ (funcall (or (and (boundp 'find-tag-default-function)\r
+ find-tag-default-function)\r
+ (get major-mode 'find-tag-default-function)\r
+ ;; XEmacs 19.12 has `find-tag-default-hook'; it is\r
+ ;; automatically used within `find-tag-default':\r
+ 'find-tag-default))))))\r
+\r
+(defun cperl-info-on-command (command)\r
+ "Show documentation for Perl command COMMAND in other window.\r
+If perl-info buffer is shown in some frame, uses this frame.\r
+Customized by setting variables `cperl-shrink-wrap-info-frame',\r
+`cperl-max-help-size'."\r
+ (interactive\r
+ (let* ((default (cperl-word-at-point))\r
+ (read (read-string\r
+ (format "Find doc for Perl function (default %s): "\r
+ default))))\r
+ (list (if (equal read "")\r
+ default\r
+ read))))\r
+\r
+ (let ((buffer (current-buffer))\r
+ (cmd-desc (concat "^" (regexp-quote command) "[^a-zA-Z_0-9]")) ; "tr///"\r
+ pos isvar height iniheight frheight buf win fr1 fr2 iniwin not-loner\r
+ max-height char-height buf-list)\r
+ (if (string-match "^-[a-zA-Z]$" command)\r
+ (setq cmd-desc "^-X[ \t\n]"))\r
+ (setq isvar (string-match "^[$@%]" command)\r
+ buf (cperl-info-buffer isvar)\r
+ iniwin (selected-window)\r
+ fr1 (window-frame iniwin))\r
+ (set-buffer buf)\r
+ (beginning-of-buffer)\r
+ (or isvar\r
+ (progn (re-search-forward "^-X[ \t\n]")\r
+ (forward-line -1)))\r
+ (if (re-search-forward cmd-desc nil t)\r
+ (progn\r
+ ;; Go back to beginning of the group (ex, for qq)\r
+ (if (re-search-backward "^[ \t\n\f]")\r
+ (forward-line 1))\r
+ (beginning-of-line)\r
+ ;; Get some of\r
+ (setq pos (point)\r
+ buf-list (list buf "*info-perl-var*" "*info-perl*"))\r
+ (while (and (not win) buf-list)\r
+ (setq win (get-buffer-window (car buf-list) t))\r
+ (setq buf-list (cdr buf-list)))\r
+ (or (not win)\r
+ (eq (window-buffer win) buf)\r
+ (set-window-buffer win buf))\r
+ (and win (setq fr2 (window-frame win)))\r
+ (if (or (not fr2) (eq fr1 fr2))\r
+ (pop-to-buffer buf)\r
+ (special-display-popup-frame buf) ; Make it visible\r
+ (select-window win))\r
+ (goto-char pos) ; Needed (?!).\r
+ ;; Resize\r
+ (setq iniheight (window-height)\r
+ frheight (frame-height)\r
+ not-loner (< iniheight (1- frheight))) ; Are not alone\r
+ (cond ((if not-loner cperl-max-help-size\r
+ cperl-shrink-wrap-info-frame)\r
+ (setq height\r
+ (+ 2\r
+ (count-lines\r
+ pos\r
+ (save-excursion\r
+ (if (re-search-forward\r
+ "^[ \t][^\n]*\n+\\([^ \t\n\f]\\|\\'\\)" nil t)\r
+ (match-beginning 0) (point-max)))))\r
+ max-height\r
+ (if not-loner\r
+ (/ (* (- frheight 3) cperl-max-help-size) 100)\r
+ (setq char-height (frame-char-height))\r
+ ;; Non-functioning under OS/2:\r
+ (if (eq char-height 1) (setq char-height 18))\r
+ ;; Title, menubar, + 2 for slack\r
+ (- (/ (x-display-pixel-height) char-height) 4)))\r
+ (if (> height max-height) (setq height max-height))\r
+ ;;(message "was %s doing %s" iniheight height)\r
+ (if not-loner\r
+ (enlarge-window (- height iniheight))\r
+ (set-frame-height (window-frame win) (1+ height)))))\r
+ (set-window-start (selected-window) pos))\r
+ (message "No entry for %s found." command))\r
+ ;;(pop-to-buffer buffer)\r
+ (select-window iniwin)))\r
+\r
+(defun cperl-info-on-current-command ()\r
+ "Show documentation for Perl command at point in other window."\r
+ (interactive)\r
+ (cperl-info-on-command (cperl-word-at-point)))\r
+\r
+(defun cperl-imenu-info-imenu-search ()\r
+ (if (looking-at "^-X[ \t\n]") nil\r
+ (re-search-backward\r
+ "^\n\\([-a-zA-Z_]+\\)[ \t\n]")\r
+ (forward-line 1)))\r
+\r
+(defun cperl-imenu-info-imenu-name ()\r
+ (buffer-substring\r
+ (match-beginning 1) (match-end 1)))\r
+\r
+(defun cperl-imenu-on-info ()\r
+ (interactive)\r
+ (let* ((buffer (current-buffer))\r
+ imenu-create-index-function\r
+ imenu-prev-index-position-function\r
+ imenu-extract-index-name-function\r
+ (index-item (save-restriction\r
+ (save-window-excursion\r
+ (set-buffer (cperl-info-buffer nil))\r
+ (setq imenu-create-index-function\r
+ 'imenu-default-create-index-function\r
+ imenu-prev-index-position-function\r
+ 'cperl-imenu-info-imenu-search\r
+ imenu-extract-index-name-function\r
+ 'cperl-imenu-info-imenu-name)\r
+ (imenu-choose-buffer-index)))))\r
+ (and index-item\r
+ (progn\r
+ (push-mark)\r
+ (pop-to-buffer "*info-perl*")\r
+ (cond\r
+ ((markerp (cdr index-item))\r
+ (goto-char (marker-position (cdr index-item))))\r
+ (t\r
+ (goto-char (cdr index-item))))\r
+ (set-window-start (selected-window) (point))\r
+ (pop-to-buffer buffer)))))\r
+\r
+(defun cperl-lineup (beg end &optional step minshift)\r
+ "Lineup construction in a region.\r
+Beginning of region should be at the start of a construction.\r
+All first occurrences of this construction in the lines that are\r
+partially contained in the region are lined up at the same column.\r
+\r
+MINSHIFT is the minimal amount of space to insert before the construction.\r
+STEP is the tabwidth to position constructions.\r
+If STEP is nil, `cperl-lineup-step' will be used\r
+\(or `cperl-indent-level', if `cperl-lineup-step' is `nil').\r
+Will not move the position at the start to the left."\r
+ (interactive "r")\r
+ (let (search col tcol seen b e)\r
+ (save-excursion\r
+ (goto-char end)\r
+ (end-of-line)\r
+ (setq end (point-marker))\r
+ (goto-char beg)\r
+ (skip-chars-forward " \t\f")\r
+ (setq beg (point-marker))\r
+ (indent-region beg end nil)\r
+ (goto-char beg)\r
+ (setq col (current-column))\r
+ (if (looking-at "[a-zA-Z0-9_]")\r
+ (if (looking-at "\\<[a-zA-Z0-9_]+\\>")\r
+ (setq search\r
+ (concat "\\<"\r
+ (regexp-quote\r
+ (buffer-substring (match-beginning 0)\r
+ (match-end 0))) "\\>"))\r
+ (error "Cannot line up in a middle of the word"))\r
+ (if (looking-at "$")\r
+ (error "Cannot line up end of line"))\r
+ (setq search (regexp-quote (char-to-string (following-char)))))\r
+ (setq step (or step cperl-lineup-step cperl-indent-level))\r
+ (or minshift (setq minshift 1))\r
+ (while (progn\r
+ (beginning-of-line 2)\r
+ (and (< (point) end)\r
+ (re-search-forward search end t)\r
+ (goto-char (match-beginning 0))))\r
+ (setq tcol (current-column) seen t)\r
+ (if (> tcol col) (setq col tcol)))\r
+ (or seen\r
+ (error "The construction to line up occurred only once"))\r
+ (goto-char beg)\r
+ (setq col (+ col minshift))\r
+ (if (/= (% col step) 0) (setq step (* step (1+ (/ col step)))))\r
+ (while\r
+ (progn\r
+ (setq e (point))\r
+ (skip-chars-backward " \t")\r
+ (delete-region (point) e)\r
+ (indent-to-column col) ;(make-string (- col (current-column)) ?\ ))\r
+ (beginning-of-line 2)\r
+ (and (< (point) end)\r
+ (re-search-forward search end t)\r
+ (goto-char (match-beginning 0)))))))) ; No body\r
+\r
+(defun cperl-etags (&optional add all files)\r
+ "Run etags with appropriate options for Perl files.\r
+If optional argument ALL is `recursive', will process Perl files\r
+in subdirectories too."\r
+ (interactive)\r
+ (let ((cmd "etags")\r
+ (args '("-l" "none" "-r" "/\\<\\(package\\|sub\\)[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)[ \\t]*\\(([^()]*)[ \t]*\\)?\\([{#]\\|$\\)\\)/\\4/"))\r
+ res)\r
+ (if add (setq args (cons "-a" args)))\r
+ (or files (setq files (list buffer-file-name)))\r
+ (cond\r
+ ((eq all 'recursive)\r
+ ;;(error "Not implemented: recursive")\r
+ (setq args (append (list "-e"\r
+ "sub wanted {push @ARGV, $File::Find::name if /\\.[pP][Llm]$/}\r
+ use File::Find;\r
+ find(\\&wanted, '.');\r
+ exec @ARGV;"\r
+ cmd) args)\r
+ cmd "perl"))\r
+ (all\r
+ ;;(error "Not implemented: all")\r
+ (setq args (append (list "-e"\r
+ "push @ARGV, <*.PL *.pl *.pm>;\r
+ exec @ARGV;"\r
+ cmd) args)\r
+ cmd "perl"))\r
+ (t\r
+ (setq args (append args files))))\r
+ (setq res (apply 'call-process cmd nil nil nil args))\r
+ (or (eq res 0)\r
+ (message "etags returned \"%s\"" res))))\r
+\r
+(defun cperl-toggle-auto-newline ()\r
+ "Toggle the state of `cperl-auto-newline'."\r
+ (interactive)\r
+ (setq cperl-auto-newline (not cperl-auto-newline))\r
+ (message "Newlines will %sbe auto-inserted now."\r
+ (if cperl-auto-newline "" "not ")))\r
+\r
+(defun cperl-toggle-abbrev ()\r
+ "Toggle the state of automatic keyword expansion in CPerl mode."\r
+ (interactive)\r
+ (abbrev-mode (if abbrev-mode 0 1))\r
+ (message "Perl control structure will %sbe auto-inserted now."\r
+ (if abbrev-mode "" "not ")))\r
+\r
+\r
+(defun cperl-toggle-electric ()\r
+ "Toggle the state of parentheses doubling in CPerl mode."\r
+ (interactive)\r
+ (setq cperl-electric-parens (if (cperl-val 'cperl-electric-parens) 'null t))\r
+ (message "Parentheses will %sbe auto-doubled now."\r
+ (if (cperl-val 'cperl-electric-parens) "" "not ")))\r
+\r
+(defun cperl-toggle-autohelp ()\r
+ "Toggle the state of Auto-Help on Perl constructs (put in the message area).\r
+Delay of auto-help controlled by `cperl-lazy-help-time'."\r
+ (interactive)\r
+ (if (fboundp 'run-with-idle-timer)\r
+ (progn\r
+ (if cperl-lazy-installed\r
+ (cperl-lazy-unstall)\r
+ (cperl-lazy-install))\r
+ (message "Perl help messages will %sbe automatically shown now."\r
+ (if cperl-lazy-installed "" "not ")))\r
+ (message "Cannot automatically show Perl help messages - run-with-idle-timer missing.")))\r
+\r
+(defun cperl-toggle-construct-fix ()\r
+ "Toggle whether `indent-region'/`indent-sexp' fix whitespace too."\r
+ (interactive)\r
+ (setq cperl-indent-region-fix-constructs\r
+ (if cperl-indent-region-fix-constructs\r
+ nil\r
+ 1))\r
+ (message "indent-region/indent-sexp will %sbe automatically fix whitespace."\r
+ (if cperl-indent-region-fix-constructs "" "not ")))\r
+\r
+;;;; Tags file creation.\r
+\r
+(defvar cperl-tmp-buffer " *cperl-tmp*")\r
+\r
+(defun cperl-setup-tmp-buf ()\r
+ (set-buffer (get-buffer-create cperl-tmp-buffer))\r
+ (set-syntax-table cperl-mode-syntax-table)\r
+ (buffer-disable-undo)\r
+ (auto-fill-mode 0)\r
+ (if cperl-use-syntax-table-text-property-for-tags\r
+ (progn\r
+ (make-local-variable 'parse-sexp-lookup-properties)\r
+ ;; Do not introduce variable if not needed, we check it!\r
+ (set 'parse-sexp-lookup-properties t))))\r
+\r
+(defun cperl-xsub-scan ()\r
+ (require 'cl)\r
+ (require 'imenu)\r
+ (let ((index-alist '())\r
+ (prev-pos 0) index index1 name package prefix)\r
+ (goto-char (point-min))\r
+ (if noninteractive\r
+ (message "Scanning XSUB for index")\r
+ (imenu-progress-message prev-pos 0))\r
+ ;; Search for the function\r
+ (progn ;;save-match-data\r
+ (while (re-search-forward\r
+ "^\\([ \t]*MODULE\\>[^\n]*\\<PACKAGE[ \t]*=[ \t]*\\([a-zA-Z_][a-zA-Z_0-9:]*\\)\\>\\|\\([a-zA-Z_][a-zA-Z_0-9]*\\)(\\|[ \t]*BOOT:\\)"\r
+ nil t)\r
+ (or noninteractive\r
+ (imenu-progress-message prev-pos))\r
+ (cond\r
+ ((match-beginning 2) ; SECTION\r
+ (setq package (buffer-substring (match-beginning 2) (match-end 2)))\r
+ (goto-char (match-beginning 0))\r
+ (skip-chars-forward " \t")\r
+ (forward-char 1)\r
+ (if (looking-at "[^\n]*\\<PREFIX[ \t]*=[ \t]*\\([a-zA-Z_][a-zA-Z_0-9]*\\)\\>")\r
+ (setq prefix (buffer-substring (match-beginning 1) (match-end 1)))\r
+ (setq prefix nil)))\r
+ ((not package) nil) ; C language section\r
+ ((match-beginning 3) ; XSUB\r
+ (goto-char (1+ (match-beginning 3)))\r
+ (setq index (imenu-example--name-and-position))\r
+ (setq name (buffer-substring (match-beginning 3) (match-end 3)))\r
+ (if (and prefix (string-match (concat "^" prefix) name))\r
+ (setq name (substring name (length prefix))))\r
+ (cond ((string-match "::" name) nil)\r
+ (t\r
+ (setq index1 (cons (concat package "::" name) (cdr index)))\r
+ (push index1 index-alist)))\r
+ (setcar index name)\r
+ (push index index-alist))\r
+ (t ; BOOT: section\r
+ ;; (beginning-of-line)\r
+ (setq index (imenu-example--name-and-position))\r
+ (setcar index (concat package "::BOOT:"))\r
+ (push index index-alist)))))\r
+ (or noninteractive\r
+ (imenu-progress-message prev-pos 100))\r
+ index-alist))\r
+\r
+(defvar cperl-unreadable-ok nil)\r
+\r
+(defun cperl-find-tags (ifile xs topdir)\r
+ (let ((b (get-buffer cperl-tmp-buffer)) ind lst elt pos ret rel\r
+ (cperl-pod-here-fontify nil) f file)\r
+ (save-excursion\r
+ (if b (set-buffer b)\r
+ (cperl-setup-tmp-buf))\r
+ (erase-buffer)\r
+ (condition-case err\r
+ (setq file (car (insert-file-contents ifile)))\r
+ (error (if cperl-unreadable-ok nil\r
+ (if (y-or-n-p\r
+ (format "File %s unreadable. Continue? " ifile))\r
+ (setq cperl-unreadable-ok t)\r
+ (error "Aborting: unreadable file %s" ifile)))))\r
+ (if (not file)\r
+ (message "Unreadable file %s" ifile)\r
+ (message "Scanning file %s ..." file)\r
+ (if (and cperl-use-syntax-table-text-property-for-tags\r
+ (not xs))\r
+ (condition-case err ; after __END__ may have garbage\r
+ (cperl-find-pods-heres nil nil noninteractive)\r
+ (error (message "While scanning for syntax: %s" err))))\r
+ (if xs\r
+ (setq lst (cperl-xsub-scan))\r
+ (setq ind (cperl-imenu--create-perl-index))\r
+ (setq lst (cdr (assoc "+Unsorted List+..." ind))))\r
+ (setq lst\r
+ (mapcar\r
+ (function\r
+ (lambda (elt)\r
+ (cond ((string-match "^[_a-zA-Z]" (car elt))\r
+ (goto-char (cdr elt))\r
+ (beginning-of-line) ; pos should be of the start of the line\r
+ (list (car elt)\r
+ (point)\r
+ (1+ (count-lines 1 (point))) ; 1+ since at beg-o-l\r
+ (buffer-substring (progn\r
+ (goto-char (cdr elt))\r
+ ;; After name now...\r
+ (or (eolp) (forward-char 1))\r
+ (point))\r
+ (progn\r
+ (beginning-of-line)\r
+ (point))))))))\r
+ lst))\r
+ (erase-buffer)\r
+ (while lst\r
+ (setq elt (car lst) lst (cdr lst))\r
+ (if elt\r
+ (progn\r
+ (insert (elt elt 3)\r
+ 127\r
+ (if (string-match "^package " (car elt))\r
+ (substring (car elt) 8)\r
+ (car elt) )\r
+ 1\r
+ (number-to-string (elt elt 2)) ; Line\r
+ ","\r
+ (number-to-string (1- (elt elt 1))) ; Char pos 0-based\r
+ "\n")\r
+ (if (and (string-match "^[_a-zA-Z]+::" (car elt))\r
+ (string-match "^sub[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]"\r
+ (elt elt 3)))\r
+ ;; Need to insert the name without package as well\r
+ (setq lst (cons (cons (substring (elt elt 3) \r
+ (match-beginning 1)\r
+ (match-end 1))\r
+ (cdr elt))\r
+ lst))))))\r
+ (setq pos (point))\r
+ (goto-char 1)\r
+ (setq rel file)\r
+ ;; On case-preserving filesystems (EMX on OS/2) case might be encoded in properties\r
+ (set-text-properties 0 (length rel) nil rel)\r
+ (and (equal topdir (substring rel 0 (length topdir)))\r
+ (setq rel (substring file (length topdir))))\r
+ (insert "\f\n" rel "," (number-to-string (1- pos)) "\n")\r
+ (setq ret (buffer-substring 1 (point-max)))\r
+ (erase-buffer)\r
+ (or noninteractive\r
+ (message "Scanning file %s finished" file))\r
+ ret))))\r
+\r
+(defun cperl-add-tags-recurse-noxs ()\r
+ "Add to TAGS data for Perl and XSUB files in the current directory and kids.\r
+Use as\r
+ emacs -batch -q -no-site-file -l emacs/cperl-mode.el \\r
+ -f cperl-add-tags-recurse\r
+"\r
+ (cperl-write-tags nil nil t t nil t))\r
+\r
+(defun cperl-add-tags-recurse ()\r
+ "Add to TAGS file data for Perl files in the current directory and kids.\r
+Use as\r
+ emacs -batch -q -no-site-file -l emacs/cperl-mode.el \\r
+ -f cperl-add-tags-recurse\r
+"\r
+ (cperl-write-tags nil nil t t))\r
+\r
+(defun cperl-write-tags (&optional file erase recurse dir inbuffer noxs topdir)\r
+ ;; If INBUFFER, do not select buffer, and do not save\r
+ ;; If ERASE is `ignore', do not erase, and do not try to delete old info.\r
+ (require 'etags)\r
+ (if file nil\r
+ (setq file (if dir default-directory (buffer-file-name)))\r
+ (if (and (not dir) (buffer-modified-p)) (error "Save buffer first!")))\r
+ (or topdir\r
+ (setq topdir default-directory))\r
+ (let ((tags-file-name "TAGS")\r
+ (case-fold-search (eq system-type 'emx))\r
+ xs rel tm)\r
+ (save-excursion\r
+ (cond (inbuffer nil) ; Already there\r
+ ((file-exists-p tags-file-name)\r
+ (if cperl-xemacs-p\r
+ (visit-tags-table-buffer)\r
+ (visit-tags-table-buffer tags-file-name)))\r
+ (t (set-buffer (find-file-noselect tags-file-name))))\r
+ (cond\r
+ (dir\r
+ (cond ((eq erase 'ignore))\r
+ (erase\r
+ (erase-buffer)\r
+ (setq erase 'ignore)))\r
+ (let ((files\r
+ (condition-case err\r
+ (directory-files file t\r
+ (if recurse nil cperl-scan-files-regexp)\r
+ t)\r
+ (error\r
+ (if cperl-unreadable-ok nil\r
+ (if (y-or-n-p\r
+ (format "Directory %s unreadable. Continue? " file))\r
+ (setq cperl-unreadable-ok t\r
+ tm nil) ; Return empty list\r
+ (error "Aborting: unreadable directory %s" file)))))))\r
+ (mapcar (function \r
+ (lambda (file)\r
+ (cond\r
+ ((string-match cperl-noscan-files-regexp file)\r
+ nil)\r
+ ((not (file-directory-p file))\r
+ (if (string-match cperl-scan-files-regexp file)\r
+ (cperl-write-tags file erase recurse nil t noxs topdir)))\r
+ ((not recurse) nil)\r
+ (t (cperl-write-tags file erase recurse t t noxs topdir)))))\r
+ files)))\r
+ (t\r
+ (setq xs (string-match "\\.xs$" file))\r
+ (if (not (and xs noxs))\r
+ (progn\r
+ (cond ((eq erase 'ignore) (goto-char (point-max)))\r
+ (erase (erase-buffer))\r
+ (t\r
+ (goto-char 1)\r
+ (setq rel file)\r
+ ;; On case-preserving filesystems (EMX on OS/2) case might be encoded in properties\r
+ (set-text-properties 0 (length rel) nil rel)\r
+ (and (equal topdir (substring rel 0 (length topdir)))\r
+ (setq rel (substring file (length topdir))))\r
+ (if (search-forward (concat "\f\n" rel ",") nil t)\r
+ (progn\r
+ (search-backward "\f\n")\r
+ (delete-region (point)\r
+ (save-excursion\r
+ (forward-char 1)\r
+ (if (search-forward "\f\n"\r
+ nil 'toend)\r
+ (- (point) 2)\r
+ (point-max)))))\r
+ (goto-char (point-max)))))\r
+ (insert (cperl-find-tags file xs topdir))))))\r
+ (if inbuffer nil ; Delegate to the caller\r
+ (save-buffer 0) ; No backup\r
+ (if (fboundp 'initialize-new-tags-table) ; Do we need something special in XEmacs?\r
+ (initialize-new-tags-table))))))\r
+\r
+(defvar cperl-tags-hier-regexp-list\r
+ (concat\r
+ "^\\("\r
+ "\\(package\\)\\>"\r
+ "\\|"\r
+ "sub\\>[^\n]+::"\r
+ "\\|"\r
+ "[a-zA-Z_][a-zA-Z_0-9:]*(\C-?[^\n]+::" ; XSUB?\r
+ "\\|"\r
+ "[ \t]*BOOT:\C-?[^\n]+::" ; BOOT section\r
+ "\\)"))\r
+\r
+(defvar cperl-hierarchy '(() ())\r
+ "Global hierarchy of classes.")\r
+\r
+(defun cperl-tags-hier-fill ()\r
+ ;; Suppose we are in a tag table cooked by cperl.\r
+ (goto-char 1)\r
+ (let (type pack name pos line chunk ord cons1 file str info fileind)\r
+ (while (re-search-forward cperl-tags-hier-regexp-list nil t)\r
+ (setq pos (match-beginning 0)\r
+ pack (match-beginning 2))\r
+ (beginning-of-line)\r
+ (if (looking-at (concat\r
+ "\\([^\n]+\\)"\r
+ "\C-?"\r
+ "\\([^\n]+\\)"\r
+ "\C-a"\r
+ "\\([0-9]+\\)"\r
+ ","\r
+ "\\([0-9]+\\)"))\r
+ (progn\r
+ (setq ;;str (buffer-substring (match-beginning 1) (match-end 1))\r
+ name (buffer-substring (match-beginning 2) (match-end 2))\r
+ ;;pos (buffer-substring (match-beginning 3) (match-end 3))\r
+ line (buffer-substring (match-beginning 3) (match-end 3))\r
+ ord (if pack 1 0)\r
+ file (file-of-tag)\r
+ fileind (format "%s:%s" file line)\r
+ ;; Moves to beginning of the next line:\r
+ info (cperl-etags-snarf-tag file line))\r
+ ;; Move back\r
+ (forward-char -1)\r
+ ;; Make new member of hierarchy name ==> file ==> pos if needed\r
+ (if (setq cons1 (assoc name (nth ord cperl-hierarchy)))\r
+ ;; Name known\r
+ (setcdr cons1 (cons (cons fileind (vector file info))\r
+ (cdr cons1)))\r
+ ;; First occurrence of the name, start alist\r
+ (setq cons1 (cons name (list (cons fileind (vector file info)))))\r
+ (if pack\r
+ (setcar (cdr cperl-hierarchy)\r
+ (cons cons1 (nth 1 cperl-hierarchy)))\r
+ (setcar cperl-hierarchy\r
+ (cons cons1 (car cperl-hierarchy)))))))\r
+ (end-of-line))))\r
+\r
+(defun cperl-tags-hier-init (&optional update)\r
+ "Show hierarchical menu of classes and methods.\r
+Finds info about classes by a scan of loaded TAGS files.\r
+Supposes that the TAGS files contain fully qualified function names.\r
+One may build such TAGS files from CPerl mode menu."\r
+ (interactive)\r
+ (require 'etags)\r
+ (require 'imenu)\r
+ (if (or update (null (nth 2 cperl-hierarchy)))\r
+ (let ((remover (function (lambda (elt) ; (name (file1...) (file2..))\r
+ (or (nthcdr 2 elt)\r
+ ;; Only in one file\r
+ (setcdr elt (cdr (nth 1 elt)))))))\r
+ pack name cons1 to l1 l2 l3 l4 b)\r
+ ;; (setq cperl-hierarchy '(() () ())) ; Would write into '() later!\r
+ (setq cperl-hierarchy (list l1 l2 l3))\r
+ (if cperl-xemacs-p ; Not checked\r
+ (progn\r
+ (or tags-file-name\r
+ ;; Does this work in XEmacs?\r
+ (call-interactively 'visit-tags-table))\r
+ (message "Updating list of classes...")\r
+ (set-buffer (get-file-buffer tags-file-name))\r
+ (cperl-tags-hier-fill))\r
+ (or tags-table-list\r
+ (call-interactively 'visit-tags-table))\r
+ (mapcar \r
+ (function\r
+ (lambda (tagsfile)\r
+ (message "Updating list of classes... %s" tagsfile)\r
+ (set-buffer (get-file-buffer tagsfile))\r
+ (cperl-tags-hier-fill)))\r
+ tags-table-list)\r
+ (message "Updating list of classes... postprocessing..."))\r
+ (mapcar remover (car cperl-hierarchy))\r
+ (mapcar remover (nth 1 cperl-hierarchy))\r
+ (setq to (list nil (cons "Packages: " (nth 1 cperl-hierarchy))\r
+ (cons "Methods: " (car cperl-hierarchy))))\r
+ (cperl-tags-treeify to 1)\r
+ (setcar (nthcdr 2 cperl-hierarchy)\r
+ (cperl-menu-to-keymap (cons '("+++UPDATE+++" . -999) (cdr to))))\r
+ (message "Updating list of classes: done, requesting display...")\r
+ ;;(cperl-imenu-addback (nth 2 cperl-hierarchy))\r
+ ))\r
+ (or (nth 2 cperl-hierarchy)\r
+ (error "No items found"))\r
+ (setq update\r
+;;; (imenu-choose-buffer-index "Packages: " (nth 2 cperl-hierarchy))\r
+ (if (if (boundp 'display-popup-menus-p)\r
+ (let ((f 'display-popup-menus-p))\r
+ (funcall f))\r
+ window-system)\r
+ (x-popup-menu t (nth 2 cperl-hierarchy))\r
+ (require 'tmm)\r
+ (tmm-prompt (nth 2 cperl-hierarchy))))\r
+ (if (and update (listp update))\r
+ (progn (while (cdr update) (setq update (cdr update)))\r
+ (setq update (car update)))) ; Get the last from the list\r
+ (if (vectorp update)\r
+ (progn\r
+ (find-file (elt update 0))\r
+ (cperl-etags-goto-tag-location (elt update 1))))\r
+ (if (eq update -999) (cperl-tags-hier-init t)))\r
+\r
+(defun cperl-tags-treeify (to level)\r
+ ;; cadr of `to' is read-write. On start it is a cons\r
+ (let* ((regexp (concat "^\\(" (mapconcat\r
+ 'identity\r
+ (make-list level "[_a-zA-Z0-9]+")\r
+ "::")\r
+ "\\)\\(::\\)?"))\r
+ (packages (cdr (nth 1 to)))\r
+ (methods (cdr (nth 2 to)))\r
+ l1 head tail cons1 cons2 ord writeto packs recurse\r
+ root-packages root-functions ms many_ms same_name ps\r
+ (move-deeper\r
+ (function \r
+ (lambda (elt)\r
+ (cond ((and (string-match regexp (car elt))\r
+ (or (eq ord 1) (match-end 2)))\r
+ (setq head (substring (car elt) 0 (match-end 1))\r
+ tail (if (match-end 2) (substring (car elt) \r
+ (match-end 2)))\r
+ recurse t)\r
+ (if (setq cons1 (assoc head writeto)) nil\r
+ ;; Need to init new head\r
+ (setcdr writeto (cons (list head (list "Packages: ")\r
+ (list "Methods: "))\r
+ (cdr writeto)))\r
+ (setq cons1 (nth 1 writeto)))\r
+ (setq cons2 (nth ord cons1)) ; Either packs or meths\r
+ (setcdr cons2 (cons elt (cdr cons2))))\r
+ ((eq ord 2)\r
+ (setq root-functions (cons elt root-functions)))\r
+ (t\r
+ (setq root-packages (cons elt root-packages))))))))\r
+ (setcdr to l1) ; Init to dynamic space\r
+ (setq writeto to)\r
+ (setq ord 1)\r
+ (mapcar move-deeper packages)\r
+ (setq ord 2)\r
+ (mapcar move-deeper methods)\r
+ (if recurse\r
+ (mapcar (function (lambda (elt)\r
+ (cperl-tags-treeify elt (1+ level))))\r
+ (cdr to)))\r
+ ;;Now clean up leaders with one child only\r
+ (mapcar (function (lambda (elt)\r
+ (if (not (and (listp (cdr elt)) \r
+ (eq (length elt) 2))) nil\r
+ (setcar elt (car (nth 1 elt)))\r
+ (setcdr elt (cdr (nth 1 elt))))))\r
+ (cdr to))\r
+ ;; Sort the roots of subtrees\r
+ (if (default-value 'imenu-sort-function)\r
+ (setcdr to\r
+ (sort (cdr to) (default-value 'imenu-sort-function))))\r
+ ;; Now add back functions removed from display\r
+ (mapcar (function (lambda (elt)\r
+ (setcdr to (cons elt (cdr to)))))\r
+ (if (default-value 'imenu-sort-function)\r
+ (nreverse\r
+ (sort root-functions (default-value 'imenu-sort-function)))\r
+ root-functions))\r
+ ;; Now add back packages removed from display\r
+ (mapcar (function (lambda (elt)\r
+ (setcdr to (cons (cons (concat "package " (car elt)) \r
+ (cdr elt)) \r
+ (cdr to)))))\r
+ (if (default-value 'imenu-sort-function)\r
+ (nreverse\r
+ (sort root-packages (default-value 'imenu-sort-function)))\r
+ root-packages))))\r
+\r
+;;;(x-popup-menu t\r
+;;; '(keymap "Name1"\r
+;;; ("Ret1" "aa")\r
+;;; ("Head1" "ab"\r
+;;; keymap "Name2"\r
+;;; ("Tail1" "x") ("Tail2" "y"))))\r
+\r
+(defun cperl-list-fold (list name limit)\r
+ (let (list1 list2 elt1 (num 0))\r
+ (if (<= (length list) limit) list\r
+ (setq list1 nil list2 nil)\r
+ (while list\r
+ (setq num (1+ num)\r
+ elt1 (car list)\r
+ list (cdr list))\r
+ (if (<= num imenu-max-items)\r
+ (setq list2 (cons elt1 list2))\r
+ (setq list1 (cons (cons name\r
+ (nreverse list2))\r
+ list1)\r
+ list2 (list elt1)\r
+ num 1)))\r
+ (nreverse (cons (cons name\r
+ (nreverse list2))\r
+ list1)))))\r
+\r
+(defun cperl-menu-to-keymap (menu &optional name)\r
+ (let (list)\r
+ (cons 'keymap\r
+ (mapcar\r
+ (function\r
+ (lambda (elt)\r
+ (cond ((listp (cdr elt))\r
+ (setq list (cperl-list-fold\r
+ (cdr elt) (car elt) imenu-max-items))\r
+ (cons nil\r
+ (cons (car elt)\r
+ (cperl-menu-to-keymap list))))\r
+ (t\r
+ (list (cdr elt) (car elt) t))))) ; t is needed in 19.34\r
+ (cperl-list-fold menu "Root" imenu-max-items)))))\r
+\r
+\f\r
+(defvar cperl-bad-style-regexp\r
+ (mapconcat 'identity\r
+ '("[^-\n\t <>=+!.&|(*/'`\"#^][-=+<>!|&^]" ; char sign\r
+ "[-<>=+^&|]+[^- \t\n=+<>~]") ; sign+ char \r
+ "\\|")\r
+ "Finds places such that insertion of a whitespace may help a lot.")\r
+\r
+(defvar cperl-not-bad-style-regexp\r
+ (mapconcat \r
+ 'identity\r
+ '("[^-\t <>=+]\\(--\\|\\+\\+\\)" ; var-- var++\r
+ "[a-zA-Z0-9_][|&][a-zA-Z0-9_$]" ; abc|def abc&def are often used.\r
+ "&[(a-zA-Z0-9_$]" ; &subroutine &(var->field)\r
+ "<\\$?\\sw+\\(\\.\\sw+\\)?>" ; <IN> <stdin.h>\r
+ "-[a-zA-Z][ \t]+[_$\"'`a-zA-Z]" ; -f file, -t STDIN\r
+ "-[0-9]" ; -5\r
+ "\\+\\+" ; ++var\r
+ "--" ; --var\r
+ ".->" ; a->b\r
+ "->" ; a SPACE ->b\r
+ "\\[-" ; a[-1]\r
+ "\\\\[&$@*\\\\]" ; \&func\r
+ "^=" ; =head\r
+ "\\$." ; $|\r
+ "<<[a-zA-Z_'\"`]" ; <<FOO, <<'FOO'\r
+ "||"\r
+ "&&"\r
+ "[CBIXSLFZ]<\\(\\sw\\|\\s \\|\\s_\\|[\n]\\)*>" ; C<code like text>\r
+ "-[a-zA-Z_0-9]+[ \t]*=>" ; -option => value\r
+ ;; Unaddressed trouble spots: = -abc, f(56, -abc) --- specialcased below\r
+ ;;"[*/+-|&<.]+="\r
+ )\r
+ "\\|")\r
+ "If matches at the start of match found by `my-bad-c-style-regexp',\r
+insertion of a whitespace will not help.")\r
+\r
+(defvar found-bad)\r
+\r
+(defun cperl-find-bad-style ()\r
+ "Find places in the buffer where insertion of a whitespace may help.\r
+Prompts user for insertion of spaces.\r
+Currently it is tuned to C and Perl syntax."\r
+ (interactive)\r
+ (let (found-bad (p (point)))\r
+ (setq last-nonmenu-event 13) ; To disable popup\r
+ (beginning-of-buffer)\r
+ (map-y-or-n-p "Insert space here? "\r
+ (lambda (arg) (insert " "))\r
+ 'cperl-next-bad-style\r
+ '("location" "locations" "insert a space into")\r
+ '((?\C-r (lambda (arg)\r
+ (let ((buffer-quit-function\r
+ 'exit-recursive-edit))\r
+ (message "Exit with Esc Esc")\r
+ (recursive-edit)\r
+ t)) ; Consider acted upon\r
+ "edit, exit with Esc Esc")\r
+ (?e (lambda (arg)\r
+ (let ((buffer-quit-function\r
+ 'exit-recursive-edit))\r
+ (message "Exit with Esc Esc")\r
+ (recursive-edit)\r
+ t)) ; Consider acted upon\r
+ "edit, exit with Esc Esc"))\r
+ t)\r
+ (if found-bad (goto-char found-bad)\r
+ (goto-char p)\r
+ (message "No appropriate place found"))))\r
+\r
+(defun cperl-next-bad-style ()\r
+ (let (p (not-found t) (point (point)) found)\r
+ (while (and not-found\r
+ (re-search-forward cperl-bad-style-regexp nil 'to-end))\r
+ (setq p (point))\r
+ (goto-char (match-beginning 0))\r
+ (if (or\r
+ (looking-at cperl-not-bad-style-regexp)\r
+ ;; Check for a < -b and friends\r
+ (and (eq (following-char) ?\-)\r
+ (save-excursion\r
+ (skip-chars-backward " \t\n")\r
+ (memq (preceding-char) '(?\= ?\> ?\< ?\, ?\( ?\[ ?\{))))\r
+ ;; Now check for syntax type\r
+ (save-match-data\r
+ (setq found (point))\r
+ (beginning-of-defun)\r
+ (let ((pps (parse-partial-sexp (point) found)))\r
+ (or (nth 3 pps) (nth 4 pps) (nth 5 pps)))))\r
+ (goto-char (match-end 0))\r
+ (goto-char (1- p))\r
+ (setq not-found nil\r
+ found-bad found)))\r
+ (not not-found)))\r
+\r
+\f\r
+;;; Getting help\r
+(defvar cperl-have-help-regexp\r
+ ;;(concat "\\("\r
+ (mapconcat\r
+ 'identity\r
+ '("[$@%*&][0-9a-zA-Z_:]+\\([ \t]*[[{]\\)?" ; Usual variable\r
+ "[$@]\\^[a-zA-Z]" ; Special variable\r
+ "[$@][^ \n\t]" ; Special variable\r
+ "-[a-zA-Z]" ; File test\r
+ "\\\\[a-zA-Z0]" ; Special chars\r
+ "^=[a-z][a-zA-Z0-9_]*" ; POD sections\r
+ "[-!&*+,-./<=>?\\\\^|~]+" ; Operator\r
+ "[a-zA-Z_0-9:]+" ; symbol or number\r
+ "x="\r
+ "#!")\r
+ ;;"\\)\\|\\("\r
+ "\\|")\r
+ ;;"\\)"\r
+ ;;)\r
+ "Matches places in the buffer we can find help for.")\r
+\r
+(defvar cperl-message-on-help-error t)\r
+(defvar cperl-help-from-timer nil)\r
+\r
+(defun cperl-word-at-point-hard ()\r
+ ;; Does not save-excursion\r
+ ;; Get to the something meaningful\r
+ (or (eobp) (eolp) (forward-char 1))\r
+ (re-search-backward "[-a-zA-Z0-9_:!&*+,-./<=>?\\\\^|~$%@]"\r
+ (save-excursion (beginning-of-line) (point))\r
+ 'to-beg)\r
+ ;; (cond\r
+ ;; ((or (eobp) (looking-at "[][ \t\n{}();,]")) ; Not at a symbol\r
+ ;; (skip-chars-backward " \n\t\r({[]});,")\r
+ ;; (or (bobp) (backward-char 1))))\r
+ ;; Try to backtrace\r
+ (cond\r
+ ((looking-at "[a-zA-Z0-9_:]") ; symbol\r
+ (skip-chars-backward "a-zA-Z0-9_:")\r
+ (cond\r
+ ((and (eq (preceding-char) ?^) ; $^I\r
+ (eq (char-after (- (point) 2)) ?\$))\r
+ (forward-char -2))\r
+ ((memq (preceding-char) (append "*$@%&\\" nil)) ; *glob\r
+ (forward-char -1))\r
+ ((and (eq (preceding-char) ?\=)\r
+ (eq (current-column) 1))\r
+ (forward-char -1))) ; =head1\r
+ (if (and (eq (preceding-char) ?\<)\r
+ (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; <FH>\r
+ (forward-char -1)))\r
+ ((and (looking-at "=") (eq (preceding-char) ?x)) ; x=\r
+ (forward-char -1))\r
+ ((and (looking-at "\\^") (eq (preceding-char) ?\$)) ; $^I\r
+ (forward-char -1))\r
+ ((looking-at "[-!&*+,-./<=>?\\\\^|~]")\r
+ (skip-chars-backward "-!&*+,-./<=>?\\\\^|~")\r
+ (cond\r
+ ((and (eq (preceding-char) ?\$)\r
+ (not (eq (char-after (- (point) 2)) ?\$))) ; $-\r
+ (forward-char -1))\r
+ ((and (eq (following-char) ?\>)\r
+ (string-match "[a-zA-Z0-9_]" (char-to-string (preceding-char)))\r
+ (save-excursion\r
+ (forward-sexp -1)\r
+ (and (eq (preceding-char) ?\<)\r
+ (looking-at "\\$?[a-zA-Z0-9_:]+>")))) ; <FH>\r
+ (search-backward "<"))))\r
+ ((and (eq (following-char) ?\$)\r
+ (eq (preceding-char) ?\<)\r
+ (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; <$fh>\r
+ (forward-char -1)))\r
+ (if (looking-at cperl-have-help-regexp)\r
+ (buffer-substring (match-beginning 0) (match-end 0))))\r
+\r
+(defun cperl-get-help ()\r
+ "Get one-line docs on the symbol at the point.\r
+The data for these docs is a little bit obsolete and may be in fact longer\r
+than a line. Your contribution to update/shorten it is appreciated."\r
+ (interactive)\r
+ (save-match-data ; May be called "inside" query-replace\r
+ (save-excursion\r
+ (let ((word (cperl-word-at-point-hard)))\r
+ (if word\r
+ (if (and cperl-help-from-timer ; Bail out if not in mainland\r
+ (not (string-match "^#!\\|\\\\\\|^=" word)) ; Show help even in comments/strings.\r
+ (or (memq (get-text-property (point) 'face)\r
+ '(font-lock-comment-face font-lock-string-face))\r
+ (memq (get-text-property (point) 'syntax-type)\r
+ '(pod here-doc format))))\r
+ nil\r
+ (cperl-describe-perl-symbol word))\r
+ (if cperl-message-on-help-error\r
+ (message "Nothing found for %s..."\r
+ (buffer-substring (point) (min (+ 5 (point)) (point-max))))))))))\r
+\r
+;;; Stolen from perl-descr.el by Johan Vromans:\r
+\r
+(defvar cperl-doc-buffer " *perl-doc*"\r
+ "Where the documentation can be found.")\r
+\r
+(defun cperl-describe-perl-symbol (val)\r
+ "Display the documentation of symbol at point, a Perl operator."\r
+ (let ((enable-recursive-minibuffers t)\r
+ args-file regexp)\r
+ (cond\r
+ ((string-match "^[&*][a-zA-Z_]" val)\r
+ (setq val (concat (substring val 0 1) "NAME")))\r
+ ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*\\[" val)\r
+ (setq val (concat "@" (substring val 1 (match-end 1)))))\r
+ ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*{" val)\r
+ (setq val (concat "%" (substring val 1 (match-end 1)))))\r
+ ((and (string= val "x") (string-match "^x=" val))\r
+ (setq val "x="))\r
+ ((string-match "^\\$[\C-a-\C-z]" val)\r
+ (setq val (concat "$^" (char-to-string (+ ?A -1 (aref val 1))))))\r
+ ((string-match "^CORE::" val)\r
+ (setq val "CORE::"))\r
+ ((string-match "^SUPER::" val)\r
+ (setq val "SUPER::"))\r
+ ((and (string= "<" val) (string-match "^<\\$?[a-zA-Z0-9_:]+>" val))\r
+ (setq val "<NAME>")))\r
+ (setq regexp (concat "^"\r
+ "\\([^a-zA-Z0-9_:]+[ \t]+\\)?"\r
+ (regexp-quote val)\r
+ "\\([ \t([/]\\|$\\)"))\r
+\r
+ ;; get the buffer with the documentation text\r
+ (cperl-switch-to-doc-buffer)\r
+\r
+ ;; lookup in the doc\r
+ (goto-char (point-min))\r
+ (let ((case-fold-search nil))\r
+ (list\r
+ (if (re-search-forward regexp (point-max) t)\r
+ (save-excursion\r
+ (beginning-of-line 1)\r
+ (let ((lnstart (point)))\r
+ (end-of-line)\r
+ (message "%s" (buffer-substring lnstart (point)))))\r
+ (if cperl-message-on-help-error\r
+ (message "No definition for %s" val)))))))\r
+\r
+(defvar cperl-short-docs 'please-ignore-this-line\r
+ ;; Perl4 version was written by Johan Vromans (jvromans@squirrel.nl)\r
+ "# based on '@(#)@ perl-descr.el 1.9 - describe-perl-symbol' [Perl 5]\r
+... Range (list context); flip/flop [no flop when flip] (scalar context).\r
+! ... Logical negation.\r
+... != ... Numeric inequality.\r
+... !~ ... Search pattern, substitution, or translation (negated).\r
+$! In numeric context: errno. In a string context: error string.\r
+$\" The separator which joins elements of arrays interpolated in strings.\r
+$# The output format for printed numbers. Default is %.15g or close.\r
+$$ Process number of this script. Changes in the fork()ed child process.\r
+$% The current page number of the currently selected output channel.\r
+\r
+ The following variables are always local to the current block:\r
+\r
+$1 Match of the 1st set of parentheses in the last match (auto-local).\r
+$2 Match of the 2nd set of parentheses in the last match (auto-local).\r
+$3 Match of the 3rd set of parentheses in the last match (auto-local).\r
+$4 Match of the 4th set of parentheses in the last match (auto-local).\r
+$5 Match of the 5th set of parentheses in the last match (auto-local).\r
+$6 Match of the 6th set of parentheses in the last match (auto-local).\r
+$7 Match of the 7th set of parentheses in the last match (auto-local).\r
+$8 Match of the 8th set of parentheses in the last match (auto-local).\r
+$9 Match of the 9th set of parentheses in the last match (auto-local).\r
+$& The string matched by the last pattern match (auto-local).\r
+$' The string after what was matched by the last match (auto-local).\r
+$` The string before what was matched by the last match (auto-local).\r
+\r
+$( The real gid of this process.\r
+$) The effective gid of this process.\r
+$* Deprecated: Set to 1 to do multiline matching within a string.\r
+$+ The last bracket matched by the last search pattern.\r
+$, The output field separator for the print operator.\r
+$- The number of lines left on the page.\r
+$. The current input line number of the last filehandle that was read.\r
+$/ The input record separator, newline by default.\r
+$0 Name of the file containing the current perl script (read/write).\r
+$: String may be broken after these characters to fill ^-lines in a format.\r
+$; Subscript separator for multi-dim array emulation. Default \"\\034\".\r
+$< The real uid of this process.\r
+$= The page length of the current output channel. Default is 60 lines.\r
+$> The effective uid of this process.\r
+$? The status returned by the last ``, pipe close or `system'.\r
+$@ The perl error message from the last eval or do @var{EXPR} command.\r
+$ARGV The name of the current file used with <> .\r
+$[ Deprecated: The index of the first element/char in an array/string.\r
+$\\ The output record separator for the print operator.\r
+$] The perl version string as displayed with perl -v.\r
+$^ The name of the current top-of-page format.\r
+$^A The current value of the write() accumulator for format() lines.\r
+$^D The value of the perl debug (-D) flags.\r
+$^E Information about the last system error other than that provided by $!.\r
+$^F The highest system file descriptor, ordinarily 2.\r
+$^H The current set of syntax checks enabled by `use strict'.\r
+$^I The value of the in-place edit extension (perl -i option).\r
+$^L What formats output to perform a formfeed. Default is \f.\r
+$^M A buffer for emergency memory allocation when running out of memory.\r
+$^O The operating system name under which this copy of Perl was built.\r
+$^P Internal debugging flag.\r
+$^T The time the script was started. Used by -A/-M/-C file tests.\r
+$^W True if warnings are requested (perl -w flag).\r
+$^X The name under which perl was invoked (argv[0] in C-speech).\r
+$_ The default input and pattern-searching space.\r
+$| Auto-flush after write/print on current output channel? Default 0.\r
+$~ The name of the current report format.\r
+... % ... Modulo division.\r
+... %= ... Modulo division assignment.\r
+%ENV Contains the current environment.\r
+%INC List of files that have been require-d or do-ne.\r
+%SIG Used to set signal handlers for various signals.\r
+... & ... Bitwise and.\r
+... && ... Logical and.\r
+... &&= ... Logical and assignment.\r
+... &= ... Bitwise and assignment.\r
+... * ... Multiplication.\r
+... ** ... Exponentiation.\r
+*NAME Glob: all objects refered by NAME. *NAM1 = *NAM2 aliases NAM1 to NAM2.\r
+&NAME(arg0, ...) Subroutine call. Arguments go to @_.\r
+... + ... Addition. +EXPR Makes EXPR into scalar context.\r
+++ Auto-increment (magical on strings). ++EXPR EXPR++\r
+... += ... Addition assignment.\r
+, Comma operator.\r
+... - ... Subtraction.\r
+-- Auto-decrement (NOT magical on strings). --EXPR EXPR--\r
+... -= ... Subtraction assignment.\r
+-A Access time in days since script started.\r
+-B File is a non-text (binary) file.\r
+-C Inode change time in days since script started.\r
+-M Age in days since script started.\r
+-O File is owned by real uid.\r
+-R File is readable by real uid.\r
+-S File is a socket .\r
+-T File is a text file.\r
+-W File is writable by real uid.\r
+-X File is executable by real uid.\r
+-b File is a block special file.\r
+-c File is a character special file.\r
+-d File is a directory.\r
+-e File exists .\r
+-f File is a plain file.\r
+-g File has setgid bit set.\r
+-k File has sticky bit set.\r
+-l File is a symbolic link.\r
+-o File is owned by effective uid.\r
+-p File is a named pipe (FIFO).\r
+-r File is readable by effective uid.\r
+-s File has non-zero size.\r
+-t Tests if filehandle (STDIN by default) is opened to a tty.\r
+-u File has setuid bit set.\r
+-w File is writable by effective uid.\r
+-x File is executable by effective uid.\r
+-z File has zero size.\r
+. Concatenate strings.\r
+.. Range (list context); flip/flop (scalar context) operator.\r
+.= Concatenate assignment strings\r
+... / ... Division. /PATTERN/ioxsmg Pattern match\r
+... /= ... Division assignment.\r
+/PATTERN/ioxsmg Pattern match.\r
+... < ... Numeric less than. <pattern> Glob. See <NAME>, <> as well.\r
+<NAME> Reads line from filehandle NAME (a bareword or dollar-bareword).\r
+<pattern> Glob (Unless pattern is bareword/dollar-bareword - see <NAME>).\r
+<> Reads line from union of files in @ARGV (= command line) and STDIN.\r
+... << ... Bitwise shift left. << start of HERE-DOCUMENT.\r
+... <= ... Numeric less than or equal to.\r
+... <=> ... Numeric compare.\r
+... = ... Assignment.\r
+... == ... Numeric equality.\r
+... =~ ... Search pattern, substitution, or translation\r
+... > ... Numeric greater than.\r
+... >= ... Numeric greater than or equal to.\r
+... >> ... Bitwise shift right.\r
+... >>= ... Bitwise shift right assignment.\r
+... ? ... : ... Condition=if-then-else operator. ?PAT? One-time pattern match.\r
+?PATTERN? One-time pattern match.\r
+@ARGV Command line arguments (not including the command name - see $0).\r
+@INC List of places to look for perl scripts during do/include/use.\r
+@_ Parameter array for subroutines; result of split() unless in list context.\r
+\\ Creates reference to what follows, like \$var, or quotes non-\w in strings.\r
+\\0 Octal char, e.g. \\033.\r
+\\E Case modification terminator. See \\Q, \\L, and \\U.\r
+\\L Lowercase until \\E . See also \l, lc.\r
+\\U Upcase until \\E . See also \u, uc.\r
+\\Q Quote metacharacters until \\E . See also quotemeta.\r
+\\a Alarm character (octal 007).\r
+\\b Backspace character (octal 010).\r
+\\c Control character, e.g. \\c[ .\r
+\\e Escape character (octal 033).\r
+\\f Formfeed character (octal 014).\r
+\\l Lowercase the next character. See also \\L and \\u, lcfirst.\r
+\\n Newline character (octal 012 on most systems).\r
+\\r Return character (octal 015 on most systems).\r
+\\t Tab character (octal 011).\r
+\\u Upcase the next character. See also \\U and \\l, ucfirst.\r
+\\x Hex character, e.g. \\x1b.\r
+... ^ ... Bitwise exclusive or.\r
+__END__ Ends program source.\r
+__DATA__ Ends program source.\r
+__FILE__ Current (source) filename.\r
+__LINE__ Current line in current source.\r
+__PACKAGE__ Current package.\r
+ARGV Default multi-file input filehandle. <ARGV> is a synonym for <>.\r
+ARGVOUT Output filehandle with -i flag.\r
+BEGIN { ... } Immediately executed (during compilation) piece of code.\r
+END { ... } Pseudo-subroutine executed after the script finishes.\r
+CHECK { ... } Pseudo-subroutine executed after the script is compiled.\r
+INIT { ... } Pseudo-subroutine executed before the script starts running.\r
+DATA Input filehandle for what follows after __END__ or __DATA__.\r
+accept(NEWSOCKET,GENERICSOCKET)\r
+alarm(SECONDS)\r
+atan2(X,Y)\r
+bind(SOCKET,NAME)\r
+binmode(FILEHANDLE)\r
+caller[(LEVEL)]\r
+chdir(EXPR)\r
+chmod(LIST)\r
+chop[(LIST|VAR)]\r
+chown(LIST)\r
+chroot(FILENAME)\r
+close(FILEHANDLE)\r
+closedir(DIRHANDLE)\r
+... cmp ... String compare.\r
+connect(SOCKET,NAME)\r
+continue of { block } continue { block }. Is executed after `next' or at end.\r
+cos(EXPR)\r
+crypt(PLAINTEXT,SALT)\r
+dbmclose(%HASH)\r
+dbmopen(%HASH,DBNAME,MODE)\r
+defined(EXPR)\r
+delete($HASH{KEY})\r
+die(LIST)\r
+do { ... }|SUBR while|until EXPR executes at least once\r
+do(EXPR|SUBR([LIST])) (with while|until executes at least once)\r
+dump LABEL\r
+each(%HASH)\r
+endgrent\r
+endhostent\r
+endnetent\r
+endprotoent\r
+endpwent\r
+endservent\r
+eof[([FILEHANDLE])]\r
+... eq ... String equality.\r
+eval(EXPR) or eval { BLOCK }\r
+exec(LIST)\r
+exit(EXPR)\r
+exp(EXPR)\r
+fcntl(FILEHANDLE,FUNCTION,SCALAR)\r
+fileno(FILEHANDLE)\r
+flock(FILEHANDLE,OPERATION)\r
+for (EXPR;EXPR;EXPR) { ... }\r
+foreach [VAR] (@ARRAY) { ... }\r
+fork\r
+... ge ... String greater than or equal.\r
+getc[(FILEHANDLE)]\r
+getgrent\r
+getgrgid(GID)\r
+getgrnam(NAME)\r
+gethostbyaddr(ADDR,ADDRTYPE)\r
+gethostbyname(NAME)\r
+gethostent\r
+getlogin\r
+getnetbyaddr(ADDR,ADDRTYPE)\r
+getnetbyname(NAME)\r
+getnetent\r
+getpeername(SOCKET)\r
+getpgrp(PID)\r
+getppid\r
+getpriority(WHICH,WHO)\r
+getprotobyname(NAME)\r
+getprotobynumber(NUMBER)\r
+getprotoent\r
+getpwent\r
+getpwnam(NAME)\r
+getpwuid(UID)\r
+getservbyname(NAME,PROTO)\r
+getservbyport(PORT,PROTO)\r
+getservent\r
+getsockname(SOCKET)\r
+getsockopt(SOCKET,LEVEL,OPTNAME)\r
+gmtime(EXPR)\r
+goto LABEL\r
+... gt ... String greater than.\r
+hex(EXPR)\r
+if (EXPR) { ... } [ elsif (EXPR) { ... } ... ] [ else { ... } ] or EXPR if EXPR\r
+index(STR,SUBSTR[,OFFSET])\r
+int(EXPR)\r
+ioctl(FILEHANDLE,FUNCTION,SCALAR)\r
+join(EXPR,LIST)\r
+keys(%HASH)\r
+kill(LIST)\r
+last [LABEL]\r
+... le ... String less than or equal.\r
+length(EXPR)\r
+link(OLDFILE,NEWFILE)\r
+listen(SOCKET,QUEUESIZE)\r
+local(LIST)\r
+localtime(EXPR)\r
+log(EXPR)\r
+lstat(EXPR|FILEHANDLE|VAR)\r
+... lt ... String less than.\r
+m/PATTERN/iogsmx\r
+mkdir(FILENAME,MODE)\r
+msgctl(ID,CMD,ARG)\r
+msgget(KEY,FLAGS)\r
+msgrcv(ID,VAR,SIZE,TYPE.FLAGS)\r
+msgsnd(ID,MSG,FLAGS)\r
+my VAR or my (VAR1,...) Introduces a lexical variable ($VAR, @ARR, or %HASH).\r
+our VAR or our (VAR1,...) Lexically enable a global variable ($V, @A, or %H).\r
+... ne ... String inequality.\r
+next [LABEL]\r
+oct(EXPR)\r
+open(FILEHANDLE[,EXPR])\r
+opendir(DIRHANDLE,EXPR)\r
+ord(EXPR) ASCII value of the first char of the string.\r
+pack(TEMPLATE,LIST)\r
+package NAME Introduces package context.\r
+pipe(READHANDLE,WRITEHANDLE) Create a pair of filehandles on ends of a pipe.\r
+pop(ARRAY)\r
+print [FILEHANDLE] [(LIST)]\r
+printf [FILEHANDLE] (FORMAT,LIST)\r
+push(ARRAY,LIST)\r
+q/STRING/ Synonym for 'STRING'\r
+qq/STRING/ Synonym for \"STRING\"\r
+qx/STRING/ Synonym for `STRING`\r
+rand[(EXPR)]\r
+read(FILEHANDLE,SCALAR,LENGTH[,OFFSET])\r
+readdir(DIRHANDLE)\r
+readlink(EXPR)\r
+recv(SOCKET,SCALAR,LEN,FLAGS)\r
+redo [LABEL]\r
+rename(OLDNAME,NEWNAME)\r
+require [FILENAME | PERL_VERSION]\r
+reset[(EXPR)]\r
+return(LIST)\r
+reverse(LIST)\r
+rewinddir(DIRHANDLE)\r
+rindex(STR,SUBSTR[,OFFSET])\r
+rmdir(FILENAME)\r
+s/PATTERN/REPLACEMENT/gieoxsm\r
+scalar(EXPR)\r
+seek(FILEHANDLE,POSITION,WHENCE)\r
+seekdir(DIRHANDLE,POS)\r
+select(FILEHANDLE | RBITS,WBITS,EBITS,TIMEOUT)\r
+semctl(ID,SEMNUM,CMD,ARG)\r
+semget(KEY,NSEMS,SIZE,FLAGS)\r
+semop(KEY,...)\r
+send(SOCKET,MSG,FLAGS[,TO])\r
+setgrent\r
+sethostent(STAYOPEN)\r
+setnetent(STAYOPEN)\r
+setpgrp(PID,PGRP)\r
+setpriority(WHICH,WHO,PRIORITY)\r
+setprotoent(STAYOPEN)\r
+setpwent\r
+setservent(STAYOPEN)\r
+setsockopt(SOCKET,LEVEL,OPTNAME,OPTVAL)\r
+shift[(ARRAY)]\r
+shmctl(ID,CMD,ARG)\r
+shmget(KEY,SIZE,FLAGS)\r
+shmread(ID,VAR,POS,SIZE)\r
+shmwrite(ID,STRING,POS,SIZE)\r
+shutdown(SOCKET,HOW)\r
+sin(EXPR)\r
+sleep[(EXPR)]\r
+socket(SOCKET,DOMAIN,TYPE,PROTOCOL)\r
+socketpair(SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL)\r
+sort [SUBROUTINE] (LIST)\r
+splice(ARRAY,OFFSET[,LENGTH[,LIST]])\r
+split[(/PATTERN/[,EXPR[,LIMIT]])]\r
+sprintf(FORMAT,LIST)\r
+sqrt(EXPR)\r
+srand(EXPR)\r
+stat(EXPR|FILEHANDLE|VAR)\r
+study[(SCALAR)]\r
+sub [NAME [(format)]] { BODY } sub NAME [(format)]; sub [(format)] {...}\r
+substr(EXPR,OFFSET[,LEN])\r
+symlink(OLDFILE,NEWFILE)\r
+syscall(LIST)\r
+sysread(FILEHANDLE,SCALAR,LENGTH[,OFFSET])\r
+system(LIST)\r
+syswrite(FILEHANDLE,SCALAR,LENGTH[,OFFSET])\r
+tell[(FILEHANDLE)]\r
+telldir(DIRHANDLE)\r
+time\r
+times\r
+tr/SEARCHLIST/REPLACEMENTLIST/cds\r
+truncate(FILE|EXPR,LENGTH)\r
+umask[(EXPR)]\r
+undef[(EXPR)]\r
+unless (EXPR) { ... } [ else { ... } ] or EXPR unless EXPR\r
+unlink(LIST)\r
+unpack(TEMPLATE,EXPR)\r
+unshift(ARRAY,LIST)\r
+until (EXPR) { ... } EXPR until EXPR\r
+utime(LIST)\r
+values(%HASH)\r
+vec(EXPR,OFFSET,BITS)\r
+wait\r
+waitpid(PID,FLAGS)\r
+wantarray Returns true if the sub/eval is called in list context.\r
+warn(LIST)\r
+while (EXPR) { ... } EXPR while EXPR\r
+write[(EXPR|FILEHANDLE)]\r
+... x ... Repeat string or array.\r
+x= ... Repetition assignment.\r
+y/SEARCHLIST/REPLACEMENTLIST/\r
+... | ... Bitwise or.\r
+... || ... Logical or.\r
+~ ... Unary bitwise complement.\r
+#! OS interpreter indicator. If contains `perl', used for options, and -x.\r
+AUTOLOAD {...} Shorthand for `sub AUTOLOAD {...}'.\r
+CORE:: Prefix to access builtin function if imported sub obscures it.\r
+SUPER:: Prefix to lookup for a method in @ISA classes.\r
+DESTROY Shorthand for `sub DESTROY {...}'.\r
+... EQ ... Obsolete synonym of `eq'.\r
+... GE ... Obsolete synonym of `ge'.\r
+... GT ... Obsolete synonym of `gt'.\r
+... LE ... Obsolete synonym of `le'.\r
+... LT ... Obsolete synonym of `lt'.\r
+... NE ... Obsolete synonym of `ne'.\r
+abs [ EXPR ] absolute value\r
+... and ... Low-precedence synonym for &&.\r
+bless REFERENCE [, PACKAGE] Makes reference into an object of a package.\r
+chomp [LIST] Strips $/ off LIST/$_. Returns count. Special if $/ eq ''!\r
+chr Converts a number to char with the same ordinal.\r
+else Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}.\r
+elsif Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}.\r
+exists $HASH{KEY} True if the key exists.\r
+format [NAME] = Start of output format. Ended by a single dot (.) on a line.\r
+formline PICTURE, LIST Backdoor into \"format\" processing.\r
+glob EXPR Synonym of <EXPR>.\r
+lc [ EXPR ] Returns lowercased EXPR.\r
+lcfirst [ EXPR ] Returns EXPR with lower-cased first letter.\r
+grep EXPR,LIST or grep {BLOCK} LIST Filters LIST via EXPR/BLOCK.\r
+map EXPR, LIST or map {BLOCK} LIST Applies EXPR/BLOCK to elts of LIST.\r
+no PACKAGE [SYMBOL1, ...] Partial reverse for `use'. Runs `unimport' method.\r
+not ... Low-precedence synonym for ! - negation.\r
+... or ... Low-precedence synonym for ||.\r
+pos STRING Set/Get end-position of the last match over this string, see \\G.\r
+quotemeta [ EXPR ] Quote regexp metacharacters.\r
+qw/WORD1 .../ Synonym of split('', 'WORD1 ...')\r
+readline FH Synonym of <FH>.\r
+readpipe CMD Synonym of `CMD`.\r
+ref [ EXPR ] Type of EXPR when dereferenced.\r
+sysopen FH, FILENAME, MODE [, PERM] (MODE is numeric, see Fcntl.)\r
+tie VAR, PACKAGE, LIST Hide an object behind a simple Perl variable.\r
+tied Returns internal object for a tied data.\r
+uc [ EXPR ] Returns upcased EXPR.\r
+ucfirst [ EXPR ] Returns EXPR with upcased first letter.\r
+untie VAR Unlink an object from a simple Perl variable.\r
+use PACKAGE [SYMBOL1, ...] Compile-time `require' with consequent `import'.\r
+... xor ... Low-precedence synonym for exclusive or.\r
+prototype \&SUB Returns prototype of the function given a reference.\r
+=head1 Top-level heading.\r
+=head2 Second-level heading.\r
+=head3 Third-level heading (is there such?).\r
+=over [ NUMBER ] Start list.\r
+=item [ TITLE ] Start new item in the list.\r
+=back End list.\r
+=cut Switch from POD to Perl.\r
+=pod Switch from Perl to POD.\r
+")\r
+\r
+(defun cperl-switch-to-doc-buffer ()\r
+ "Go to the perl documentation buffer and insert the documentation."\r
+ (interactive)\r
+ (let ((buf (get-buffer-create cperl-doc-buffer)))\r
+ (if (interactive-p)\r
+ (switch-to-buffer-other-window buf)\r
+ (set-buffer buf))\r
+ (if (= (buffer-size) 0)\r
+ (progn\r
+ (insert (documentation-property 'cperl-short-docs\r
+ 'variable-documentation))\r
+ (setq buffer-read-only t)))))\r
+\r
+(defun cperl-beautify-regexp-piece (b e embed level)\r
+ ;; b is before the starting delimiter, e before the ending\r
+ ;; e should be a marker, may be changed, but remains "correct".\r
+ ;; EMBED is nil iff we process the whole REx.\r
+ ;; The REx is guarantied to have //x\r
+ ;; LEVEL shows how many levels deep to go\r
+ ;; position at enter and at leave is not defined\r
+ (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline code pos)\r
+ (if (not embed)\r
+ (goto-char (1+ b))\r
+ (goto-char b)\r
+ (cond ((looking-at "(\\?\\\\#") ; (?#) wrongly commented when //x-ing\r
+ (forward-char 2)\r
+ (delete-char 1)\r
+ (forward-char 1))\r
+ ((looking-at "(\\?[^a-zA-Z]")\r
+ (forward-char 3))\r
+ ((looking-at "(\\?") ; (?i)\r
+ (forward-char 2))\r
+ (t\r
+ (forward-char 1))))\r
+ (setq c (if embed (current-indentation) (1- (current-column)))\r
+ c1 (+ c (or cperl-regexp-indent-step cperl-indent-level)))\r
+ (or (looking-at "[ \t]*[\n#]")\r
+ (progn\r
+ (insert "\n")))\r
+ (goto-char e)\r
+ (beginning-of-line)\r
+ (if (re-search-forward "[^ \t]" e t)\r
+ (progn ; Something before the ending delimiter\r
+ (goto-char e)\r
+ (delete-horizontal-space)\r
+ (insert "\n")\r
+ (indent-to-column c)\r
+ (set-marker e (point))))\r
+ (goto-char b)\r
+ (end-of-line 2)\r
+ (while (< (point) (marker-position e))\r
+ (beginning-of-line)\r
+ (setq s (point)\r
+ inline t)\r
+ (skip-chars-forward " \t")\r
+ (delete-region s (point))\r
+ (indent-to-column c1)\r
+ (while (and\r
+ inline\r
+ (looking-at\r
+ (concat "\\([a-zA-Z0-9]+[^*+{?]\\)" ; 1 word\r
+ "\\|" ; Embedded variable\r
+ "\\$\\([a-zA-Z0-9_]+\\([[{]\\)?\\|[^\n \t)|]\\)" ; 2 3\r
+ "\\|" ; $ ^\r
+ "[$^]"\r
+ "\\|" ; simple-code simple-code*?\r
+ "\\(\\\\.\\|[^][()#|*+?\n]\\)\\([*+{?]\\??\\)?" ; 4 5\r
+ "\\|" ; Class\r
+ "\\(\\[\\)" ; 6\r
+ "\\|" ; Grouping\r
+ "\\((\\(\\?\\)?\\)" ; 7 8\r
+ "\\|" ; |\r
+ "\\(|\\)"))) ; 9\r
+ (goto-char (match-end 0))\r
+ (setq spaces t)\r
+ (cond ((match-beginning 1) ; Alphanum word + junk\r
+ (forward-char -1))\r
+ ((or (match-beginning 3) ; $ab[12]\r
+ (and (match-beginning 5) ; X* X+ X{2,3}\r
+ (eq (preceding-char) ?\{)))\r
+ (forward-char -1)\r
+ (forward-sexp 1))\r
+ ((match-beginning 6) ; []\r
+ (setq tmp (point))\r
+ (if (looking-at "\\^?\\]")\r
+ (goto-char (match-end 0)))\r
+ ;; XXXX POSIX classes?!\r
+ (while (and (not pos)\r
+ (re-search-forward "\\[:\\|\\]" e t))\r
+ (if (eq (preceding-char) ?:)\r
+ (or (re-search-forward ":\\]" e t)\r
+ (error "[:POSIX:]-group in []-group not terminated"))\r
+ (setq pos t)))\r
+ (or (eq (preceding-char) ?\])\r
+ (error "[]-group not terminated"))\r
+ (if (eq (following-char) ?\{)\r
+ (progn\r
+ (forward-sexp 1)\r
+ (and (eq (following-char) ??)\r
+ (forward-char 1)))\r
+ (re-search-forward "\\=\\([*+?]\\??\\)" e t)))\r
+ ((match-beginning 7) ; ()\r
+ (goto-char (match-beginning 0))\r
+ (setq pos (current-column))\r
+ (or (eq pos c1)\r
+ (progn\r
+ (delete-horizontal-space)\r
+ (insert "\n")\r
+ (indent-to-column c1)))\r
+ (setq tmp (point))\r
+ (forward-sexp 1)\r
+ ;; (or (forward-sexp 1)\r
+ ;; (progn\r
+ ;; (goto-char tmp)\r
+ ;; (error "()-group not terminated")))\r
+ (set-marker m (1- (point)))\r
+ (set-marker m1 (point))\r
+ (if (= level 1)\r
+ (if (progn ; indent rigidly if multiline\r
+ ;; In fact does not make a lot of sense, since\r
+ ;; the starting position can be already lost due\r
+ ;; to insertion of "\n" and " "\r
+ (goto-char tmp)\r
+ (search-forward "\n" m1 t))\r
+ (indent-rigidly (point) m1 (- c1 pos)))\r
+ (setq level (1- level))\r
+ (cond\r
+ ((not (match-beginning 8))\r
+ (cperl-beautify-regexp-piece tmp m t level))\r
+ ((eq (char-after (+ 2 tmp)) ?\{) ; Code\r
+ t)\r
+ ((eq (char-after (+ 2 tmp)) ?\() ; Conditional\r
+ (goto-char (+ 2 tmp))\r
+ (forward-sexp 1)\r
+ (cperl-beautify-regexp-piece (point) m t level))\r
+ ((eq (char-after (+ 2 tmp)) ?<) ; Lookbehind\r
+ (goto-char (+ 3 tmp))\r
+ (cperl-beautify-regexp-piece (point) m t level))\r
+ (t\r
+ (cperl-beautify-regexp-piece tmp m t level))))\r
+ (goto-char m1)\r
+ (cond ((looking-at "[*+?]\\??")\r
+ (goto-char (match-end 0)))\r
+ ((eq (following-char) ?\{)\r
+ (forward-sexp 1)\r
+ (if (eq (following-char) ?\?)\r
+ (forward-char))))\r
+ (skip-chars-forward " \t")\r
+ (setq spaces nil)\r
+ (if (looking-at "[#\n]")\r
+ (progn\r
+ (or (eolp) (indent-for-comment))\r
+ (beginning-of-line 2))\r
+ (delete-horizontal-space)\r
+ (insert "\n"))\r
+ (end-of-line)\r
+ (setq inline nil))\r
+ ((match-beginning 9) ; |\r
+ (forward-char -1)\r
+ (setq tmp (point))\r
+ (beginning-of-line)\r
+ (if (re-search-forward "[^ \t]" tmp t)\r
+ (progn\r
+ (goto-char tmp)\r
+ (delete-horizontal-space)\r
+ (insert "\n"))\r
+ ;; first at line\r
+ (delete-region (point) tmp))\r
+ (indent-to-column c)\r
+ (forward-char 1)\r
+ (skip-chars-forward " \t")\r
+ (setq spaces nil)\r
+ (if (looking-at "[#\n]")\r
+ (beginning-of-line 2)\r
+ (delete-horizontal-space)\r
+ (insert "\n"))\r
+ (end-of-line)\r
+ (setq inline nil)))\r
+ (or (looking-at "[ \t\n]")\r
+ (not spaces)\r
+ (insert " "))\r
+ (skip-chars-forward " \t"))\r
+ (or (looking-at "[#\n]")\r
+ (error "Unknown code `%s' in a regexp"\r
+ (buffer-substring (point) (1+ (point)))))\r
+ (and inline (end-of-line 2)))\r
+ ;; Special-case the last line of group\r
+ (if (and (>= (point) (marker-position e))\r
+ (/= (current-indentation) c))\r
+ (progn\r
+ (beginning-of-line)\r
+ (setq s (point))\r
+ (skip-chars-forward " \t")\r
+ (delete-region s (point))\r
+ (indent-to-column c)))))\r
+\r
+(defun cperl-make-regexp-x ()\r
+ ;; Returns position of the start\r
+ ;; XXX this is called too often! Need to cache the result!\r
+ (save-excursion\r
+ (or cperl-use-syntax-table-text-property\r
+ (error "I need to have a regexp marked!"))\r
+ ;; Find the start\r
+ (if (looking-at "\\s|")\r
+ nil ; good already\r
+ (if (looking-at "\\([smy]\\|qr\\)\\s|")\r
+ (forward-char 1)\r
+ (re-search-backward "\\s|"))) ; Assume it is scanned already.\r
+ ;;(forward-char 1)\r
+ (let ((b (point)) (e (make-marker)) have-x delim (c (current-column))\r
+ (sub-p (eq (preceding-char) ?s)) s)\r
+ (forward-sexp 1)\r
+ (set-marker e (1- (point)))\r
+ (setq delim (preceding-char))\r
+ (if (and sub-p (eq delim (char-after (- (point) 2))))\r
+ (error "Possible s/blah// - do not know how to deal with"))\r
+ (if sub-p (forward-sexp 1))\r
+ (if (looking-at "\\sw*x")\r
+ (setq have-x t)\r
+ (insert "x"))\r
+ ;; Protect fragile " ", "#"\r
+ (if have-x nil\r
+ (goto-char (1+ b))\r
+ (while (re-search-forward "\\(\\=\\|[^\\\\]\\)\\(\\\\\\\\\\)*[ \t\n#]" e t) ; Need to include (?#) too?\r
+ (forward-char -1)\r
+ (insert "\\")\r
+ (forward-char 1)))\r
+ b)))\r
+\r
+(defun cperl-beautify-regexp (&optional deep)\r
+ "Do it. (Experimental, may change semantics, recheck the result.)\r
+We suppose that the regexp is scanned already."\r
+ (interactive "P")\r
+ (setq deep (if deep (prefix-numeric-value deep) -1))\r
+ (save-excursion\r
+ (goto-char (cperl-make-regexp-x))\r
+ (let ((b (point)) (e (make-marker)))\r
+ (forward-sexp 1)\r
+ (set-marker e (1- (point)))\r
+ (cperl-beautify-regexp-piece b e nil deep))))\r
+\r
+(defun cperl-regext-to-level-start ()\r
+ "Goto start of an enclosing group in regexp.\r
+We suppose that the regexp is scanned already."\r
+ (interactive)\r
+ (let ((limit (cperl-make-regexp-x)) done)\r
+ (while (not done)\r
+ (or (eq (following-char) ?\()\r
+ (search-backward "(" (1+ limit) t)\r
+ (error "Cannot find `(' which starts a group"))\r
+ (setq done\r
+ (save-excursion\r
+ (skip-chars-backward "\\")\r
+ (looking-at "\\(\\\\\\\\\\)*(")))\r
+ (or done (forward-char -1)))))\r
+\r
+(defun cperl-contract-level ()\r
+ "Find an enclosing group in regexp and contract it.\r
+\(Experimental, may change semantics, recheck the result.)\r
+We suppose that the regexp is scanned already."\r
+ (interactive)\r
+ ;; (save-excursion ; Can't, breaks `cperl-contract-levels'\r
+ (cperl-regext-to-level-start)\r
+ (let ((b (point)) (e (make-marker)) s c)\r
+ (forward-sexp 1)\r
+ (set-marker e (1- (point)))\r
+ (goto-char b)\r
+ (while (re-search-forward "\\(#\\)\\|\n" e 'to-end)\r
+ (cond\r
+ ((match-beginning 1) ; #-comment\r
+ (or c (setq c (current-indentation)))\r
+ (beginning-of-line 2) ; Skip\r
+ (setq s (point))\r
+ (skip-chars-forward " \t")\r
+ (delete-region s (point))\r
+ (indent-to-column c))\r
+ (t\r
+ (delete-char -1)\r
+ (just-one-space))))))\r
+\r
+(defun cperl-contract-levels ()\r
+ "Find an enclosing group in regexp and contract all the kids.\r
+\(Experimental, may change semantics, recheck the result.)\r
+We suppose that the regexp is scanned already."\r
+ (interactive)\r
+ (save-excursion\r
+ (condition-case nil\r
+ (cperl-regext-to-level-start)\r
+ (error ; We are outside outermost group\r
+ (goto-char (cperl-make-regexp-x))))\r
+ (let ((b (point)) (e (make-marker)) s c)\r
+ (forward-sexp 1)\r
+ (set-marker e (1- (point)))\r
+ (goto-char (1+ b))\r
+ (while (re-search-forward "\\(\\\\\\\\\\)\\|(" e t)\r
+ (cond\r
+ ((match-beginning 1) ; Skip\r
+ nil)\r
+ (t ; Group\r
+ (cperl-contract-level)))))))\r
+\r
+(defun cperl-beautify-level (&optional deep)\r
+ "Find an enclosing group in regexp and beautify it.\r
+\(Experimental, may change semantics, recheck the result.)\r
+We suppose that the regexp is scanned already."\r
+ (interactive "P")\r
+ (setq deep (if deep (prefix-numeric-value deep) -1))\r
+ (save-excursion\r
+ (cperl-regext-to-level-start)\r
+ (let ((b (point)) (e (make-marker)))\r
+ (forward-sexp 1)\r
+ (set-marker e (1- (point)))\r
+ (cperl-beautify-regexp-piece b e nil deep))))\r
+\r
+(defun cperl-invert-if-unless ()\r
+ "Change `if (A) {B}' into `B if A;' etc if possible."\r
+ (interactive)\r
+ (or (looking-at "\\<")\r
+ (forward-sexp -1))\r
+ (if (looking-at "\\<\\(if\\|unless\\|while\\|until\\|for\\|foreach\\)\\>")\r
+ (let ((pos1 (point))\r
+ pos2 pos3 pos4 pos5 s1 s2 state p pos45\r
+ (s0 (buffer-substring (match-beginning 0) (match-end 0))))\r
+ (forward-sexp 2)\r
+ (setq pos3 (point))\r
+ (forward-sexp -1)\r
+ (setq pos2 (point))\r
+ (if (eq (following-char) ?\( )\r
+ (progn\r
+ (goto-char pos3)\r
+ (forward-sexp 1)\r
+ (setq pos5 (point))\r
+ (forward-sexp -1)\r
+ (setq pos4 (point))\r
+ ;; XXXX In fact may be `A if (B); {C}' ...\r
+ (if (and (eq (following-char) ?\{ )\r
+ (progn\r
+ (cperl-backward-to-noncomment pos3)\r
+ (eq (preceding-char) ?\) )))\r
+ (if (condition-case nil\r
+ (progn\r
+ (goto-char pos5)\r
+ (forward-sexp 1)\r
+ (forward-sexp -1)\r
+ (looking-at "\\<els\\(e\\|if\\)\\>"))\r
+ (error nil))\r
+ (error\r
+ "`%s' (EXPR) {BLOCK} with `else'/`elsif'" s0)\r
+ (goto-char (1- pos5))\r
+ (cperl-backward-to-noncomment pos4)\r
+ (if (eq (preceding-char) ?\;)\r
+ (forward-char -1))\r
+ (setq pos45 (point))\r
+ (goto-char pos4)\r
+ (while (re-search-forward "\\<\\(for\\|foreach\\|if\\|unless\\|while\\|until\\)\\>\\|;" pos45 t)\r
+ (setq p (match-beginning 0)\r
+ s1 (buffer-substring p (match-end 0))\r
+ state (parse-partial-sexp pos4 p))\r
+ (or (nth 3 state)\r
+ (nth 4 state)\r
+ (nth 5 state)\r
+ (error "`%s' inside `%s' BLOCK" s1 s0))\r
+ (goto-char (match-end 0)))\r
+ ;; Finally got it\r
+ (goto-char (1+ pos4))\r
+ (skip-chars-forward " \t\n")\r
+ (setq s2 (buffer-substring (point) pos45))\r
+ (goto-char pos45)\r
+ (or (looking-at ";?[ \t\n]*}")\r
+ (progn\r
+ (skip-chars-forward "; \t\n")\r
+ (setq s2 (concat s2 "\n" (buffer-substring (point) (1- pos5))))))\r
+ (and (equal s2 "")\r
+ (setq s2 "1"))\r
+ (goto-char (1- pos3))\r
+ (cperl-backward-to-noncomment pos2)\r
+ (or (looking-at "[ \t\n]*)")\r
+ (goto-char (1- pos3)))\r
+ (setq p (point))\r
+ (goto-char (1+ pos2))\r
+ (skip-chars-forward " \t\n")\r
+ (setq s1 (buffer-substring (point) p))\r
+ (delete-region pos4 pos5)\r
+ (delete-region pos2 pos3)\r
+ (goto-char pos1)\r
+ (insert s2 " ")\r
+ (just-one-space)\r
+ (forward-word 1)\r
+ (setq pos1 (point))\r
+ (insert " " s1 ";")\r
+ (delete-horizontal-space)\r
+ (forward-char -1)\r
+ (delete-horizontal-space)\r
+ (goto-char pos1)\r
+ (just-one-space)\r
+ (cperl-indent-line))\r
+ (error "`%s' (EXPR) not with an {BLOCK}" s0)))\r
+ (error "`%s' not with an (EXPR)" s0)))\r
+ (error "Not at `if', `unless', `while', `until', `for' or `foreach'")))\r
+\r
+;;; By Anthony Foiani <afoiani@uswest.com>\r
+;;; Getting help on modules in C-h f ?\r
+;;; This is a modified version of `man'.\r
+;;; Need to teach it how to lookup functions\r
+(defun cperl-perldoc (word)\r
+ "Run `perldoc' on WORD."\r
+ (interactive\r
+ (list (let* ((default-entry (cperl-word-at-point))\r
+ (input (read-string\r
+ (format "perldoc entry%s: "\r
+ (if (string= default-entry "")\r
+ ""\r
+ (format " (default %s)" default-entry))))))\r
+ (if (string= input "")\r
+ (if (string= default-entry "")\r
+ (error "No perldoc args given")\r
+ default-entry)\r
+ input))))\r
+ (require 'man)\r
+ (let* ((case-fold-search nil)\r
+ (is-func (and\r
+ (string-match "^[a-z]+$" word)\r
+ (string-match (concat "^" word "\\>")\r
+ (documentation-property\r
+ 'cperl-short-docs\r
+ 'variable-documentation))))\r
+ (manual-program (if is-func "perldoc -f" "perldoc")))\r
+ (cond\r
+ (cperl-xemacs-p\r
+ (let ((Manual-program "perldoc")\r
+ (Manual-switches (if is-func (list "-f"))))\r
+ (manual-entry word)))\r
+ (t\r
+ (Man-getpage-in-background word)))))\r
+\r
+(defun cperl-perldoc-at-point ()\r
+ "Run a `perldoc' on the word around point."\r
+ (interactive)\r
+ (cperl-perldoc (cperl-word-at-point)))\r
+\r
+(defcustom pod2man-program "pod2man"\r
+ "*File name for `pod2man'."\r
+ :type 'file\r
+ :group 'cperl)\r
+\r
+;;; By Nick Roberts <Nick.Roberts@src.bae.co.uk> (with changes)\r
+(defun cperl-pod-to-manpage ()\r
+ "Create a virtual manpage in Emacs from the Perl Online Documentation."\r
+ (interactive)\r
+ (require 'man)\r
+ (let* ((pod2man-args (concat buffer-file-name " | nroff -man "))\r
+ (bufname (concat "Man " buffer-file-name))\r
+ (buffer (generate-new-buffer bufname)))\r
+ (save-excursion\r
+ (set-buffer buffer)\r
+ (let ((process-environment (copy-sequence process-environment)))\r
+ ;; Prevent any attempt to use display terminal fanciness.\r
+ (setenv "TERM" "dumb")\r
+ (set-process-sentinel\r
+ (start-process pod2man-program buffer "sh" "-c"\r
+ (format (cperl-pod2man-build-command) pod2man-args))\r
+ 'Man-bgproc-sentinel)))))\r
+\r
+;;; Updated version by him too\r
+(defun cperl-build-manpage ()\r
+ "Create a virtual manpage in Emacs from the POD in the file."\r
+ (interactive)\r
+ (require 'man)\r
+ (cond\r
+ (cperl-xemacs-p\r
+ (let ((Manual-program "perldoc"))\r
+ (manual-entry buffer-file-name)))\r
+ (t\r
+ (let* ((manual-program "perldoc"))\r
+ (Man-getpage-in-background buffer-file-name)))))\r
+\r
+(defun cperl-pod2man-build-command ()\r
+ "Builds the entire background manpage and cleaning command."\r
+ (let ((command (concat pod2man-program " %s 2>/dev/null"))\r
+ (flist Man-filter-list))\r
+ (while (and flist (car flist))\r
+ (let ((pcom (car (car flist)))\r
+ (pargs (cdr (car flist))))\r
+ (setq command\r
+ (concat command " | " pcom " "\r
+ (mapconcat '(lambda (phrase)\r
+ (if (not (stringp phrase))\r
+ (error "Malformed Man-filter-list"))\r
+ phrase)\r
+ pargs " ")))\r
+ (setq flist (cdr flist))))\r
+ command))\r
+\r
+(defun cperl-lazy-install ()) ; Avoid a warning\r
+(defun cperl-lazy-unstall ()) ; Avoid a warning\r
+\r
+(if (fboundp 'run-with-idle-timer)\r
+ (progn\r
+ (defvar cperl-help-shown nil\r
+ "Non-nil means that the help was already shown now.")\r
+\r
+ (defvar cperl-lazy-installed nil\r
+ "Non-nil means that the lazy-help handlers are installed now.")\r
+\r
+ (defun cperl-lazy-install ()\r
+ "Switches on Auto-Help on Perl constructs (put in the message area).\r
+Delay of auto-help controlled by `cperl-lazy-help-time'."\r
+ (interactive)\r
+ (make-variable-buffer-local 'cperl-help-shown)\r
+ (if (and (cperl-val 'cperl-lazy-help-time)\r
+ (not cperl-lazy-installed))\r
+ (progn\r
+ (add-hook 'post-command-hook 'cperl-lazy-hook)\r
+ (run-with-idle-timer\r
+ (cperl-val 'cperl-lazy-help-time 1000000 5)\r
+ t\r
+ 'cperl-get-help-defer)\r
+ (setq cperl-lazy-installed t))))\r
+\r
+ (defun cperl-lazy-unstall ()\r
+ "Switches off Auto-Help on Perl constructs (put in the message area).\r
+Delay of auto-help controlled by `cperl-lazy-help-time'."\r
+ (interactive)\r
+ (remove-hook 'post-command-hook 'cperl-lazy-hook)\r
+ (cancel-function-timers 'cperl-get-help-defer)\r
+ (setq cperl-lazy-installed nil))\r
+\r
+ (defun cperl-lazy-hook ()\r
+ (setq cperl-help-shown nil))\r
+\r
+ (defun cperl-get-help-defer ()\r
+ (if (not (memq major-mode '(perl-mode cperl-mode))) nil\r
+ (let ((cperl-message-on-help-error nil) (cperl-help-from-timer t))\r
+ (cperl-get-help)\r
+ (setq cperl-help-shown t))))\r
+ (cperl-lazy-install)))\r
+\r
+\r
+;;; Plug for wrong font-lock:\r
+\r
+(defun cperl-font-lock-unfontify-region-function (beg end)\r
+ (let* ((modified (buffer-modified-p)) (buffer-undo-list t)\r
+ (inhibit-read-only t) (inhibit-point-motion-hooks t)\r
+ before-change-functions after-change-functions\r
+ deactivate-mark buffer-file-name buffer-file-truename)\r
+ (remove-text-properties beg end '(face nil))\r
+ (when (and (not modified) (buffer-modified-p))\r
+ (set-buffer-modified-p nil))))\r
+\r
+(defvar cperl-d-l nil)\r
+(defun cperl-fontify-syntaxically (end)\r
+ ;; Some vars for debugging only\r
+ ;; (message "Syntaxifying...")\r
+ (let ((dbg (point)) (iend end)\r
+ (istate (car cperl-syntax-state))\r
+ start)\r
+ (and cperl-syntaxify-unwind\r
+ (setq end (cperl-unwind-to-safe t end)))\r
+ (setq start (point))\r
+ (or cperl-syntax-done-to\r
+ (setq cperl-syntax-done-to (point-min)))\r
+ (if (or (not (boundp 'font-lock-hot-pass))\r
+ (eval 'font-lock-hot-pass)\r
+ t) ; Not debugged otherwise\r
+ ;; Need to forget what is after `start'\r
+ (setq start (min cperl-syntax-done-to start))\r
+ ;; Fontification without a change\r
+ (setq start (max cperl-syntax-done-to start)))\r
+ (and (> end start)\r
+ (setq cperl-syntax-done-to start) ; In case what follows fails\r
+ (cperl-find-pods-heres start end t nil t))\r
+ (if (eq cperl-syntaxify-by-font-lock 'message)\r
+ (message "Syntaxified %s..%s from %s to %s(%s), state %s-->%s"\r
+ dbg iend\r
+ start end cperl-syntax-done-to\r
+ istate (car cperl-syntax-state))) ; For debugging\r
+ nil)) ; Do not iterate\r
+\r
+(defun cperl-fontify-update (end)\r
+ (let ((pos (point)) prop posend)\r
+ (while (< pos end)\r
+ (setq prop (get-text-property pos 'cperl-postpone))\r
+ (setq posend (next-single-property-change pos 'cperl-postpone nil end))\r
+ (and prop (put-text-property pos posend (car prop) (cdr prop)))\r
+ (setq pos posend)))\r
+ nil) ; Do not iterate\r
+\r
+(defun cperl-update-syntaxification (from to)\r
+ (if (and cperl-use-syntax-table-text-property\r
+ cperl-syntaxify-by-font-lock\r
+ (or (null cperl-syntax-done-to)\r
+ (< cperl-syntax-done-to to)))\r
+ (progn\r
+ (save-excursion\r
+ (goto-char from)\r
+ (cperl-fontify-syntaxically to)))))\r
+\r
+(defvar cperl-version\r
+ (let ((v "$Revision: 5.0 $"))\r
+ (string-match ":\\s *\\([0-9.]+\\)" v)\r
+ (substring v (match-beginning 1) (match-end 1)))\r
+ "Version of IZ-supported CPerl package this file is based on.")\r
+\r
+(provide 'cperl-mode)\r
+\r
+;;; cperl-mode.el ends here\r
--- /dev/null
+;;; crontab-mode.el --- Mode for editing crontab files
+;;
+;; ~/share/emacs/pkg/crontab/crontab-mode.el ---
+;;
+;; $Id: crontab-mode.el,v 1.18 2004/03/10 06:51:59 harley Exp $
+;;
+
+;; Author: Harley Gorrell <harley@mahalito.net>
+;; URL: http://www.mahalito.net/~harley/elisp/crontab-mode.el
+;; License: GPL v2
+;; Keywords: cron, crontab, emacs
+
+;;; Commentary:
+;; * I want to keep my crontabs under rcs to keep a history of
+;; the file. Editing them with 'crontab -e' is rather
+;; cumbersome. My method is to keep the crontab as a file,
+;; under rcs, and check in the changes with 'C-c C-c' after
+;; editing.
+;;
+;; * The remote systems are expected to share a filesystem.
+;; If they dont, modify crontab-shell or crontab-apply to
+;; suit your needs.
+;;
+;; * You may want to add one of these to your startup:
+;; (add-to-list 'auto-mode-alist '("\\.cron\\(tab\\)?\\'" . crontab-mode))
+;; (add-to-list 'auto-mode-alist '("cron\\(tab\\)?\\." . crontab-mode))
+
+;;; History:
+;; 2003-03-16: Updated URL and contact info
+;; 2004-02-26: Use ssh to apply crontabs to remote hosts.
+
+;;; Code:
+
+(defvar crontab-suffix ".crontab"
+ "*Suffix for crontab buffers.")
+
+(defvar crontab-apply-after-save nil
+ "*Non-nil to apply the crontab after a save.")
+(make-variable-buffer-local 'crontab-apply-after-save)
+
+(defvar crontab-host nil
+ "*Hostname to use when saving the crontab to a remote host.")
+(make-variable-buffer-local 'crontab-host)
+
+(defvar crontab-user nil
+ "*Username to use when saving the crontab to a remote host.")
+(make-variable-buffer-local 'crontab-user)
+
+;; Would be better to have "\\([0-9]\\([-,][0-9]+\\)+\\|...
+(defvar crontab-unit-regexp "\\([-,0-9]+\\|\\*\\)"
+ "A regexp which matches a cron time unit.")
+
+(defvar crontab-sep-regexp "[ \t]+"
+ "A regexp to match whitespace seperating cron time units.")
+
+(defvar crontab-ruler "
+# min hour day month day-of-week command
+#(0-59) (0-23) (1-31) (1-12) (0-6)
+#
+#------------------------------------------------------------
+"
+ "*The ruler `crontab-insert-ruler' inserts.")
+
+;;
+(defvar crontab-mode-hook nil
+ "*Hook for customising `crontab-mode'.")
+
+(defvar crontab-load-hook nil
+ "*Hook run when the `crontab-mode' is loaded.")
+
+;;
+(defvar crontab-font-lock-keywords
+ (list
+ ;; Comments
+ '("^#.*$" . font-lock-comment-face)
+ ;; Blank lines are bad!
+ '("^[ \t]+$" . highlight)
+ ;; Variable defs
+ '("^\\([A-Z_]+\\)=\\(.*\\)$" .
+ ((1 font-lock-keyword-face)
+ (2 font-lock-string-face)) )
+ ;; Cron lines
+ ;; 50 * * * * /usr/gnu/bin/bash
+ (cons
+ (concat "^"
+ crontab-unit-regexp crontab-sep-regexp
+ crontab-unit-regexp crontab-sep-regexp
+ crontab-unit-regexp crontab-sep-regexp
+ crontab-unit-regexp crontab-sep-regexp
+ crontab-unit-regexp crontab-sep-regexp
+ "\\(.*\\)$")
+ '((1 font-lock-keyword-face)
+ (2 font-lock-keyword-face)
+ (3 font-lock-keyword-face)
+ (4 font-lock-keyword-face)
+ (5 font-lock-keyword-face)
+ (6 font-lock-string-face))) )
+ "Info for function `font-lock-mode'.")
+
+(defvar crontab-mode-map nil
+ "Keymap used in `crontab-mode'.")
+
+(if crontab-mode-map
+ ()
+ (setq crontab-mode-map (make-sparse-keymap))
+ (define-key crontab-mode-map "\C-c\C-c" 'crontab-save-and-apply)
+ (define-key crontab-mode-map "\C-cc" 'crontab-save-and-apply)
+ (define-key crontab-mode-map "\C-ca" 'crontab-save-and-apply-to)
+ (define-key crontab-mode-map "\C-ci" 'crontab-insert-local-var)
+ (define-key crontab-mode-map "\C-cr" 'crontab-insert-ruler))
+
+;; This will barf without the correct agent or key setup.
+(defvar crontab-rsh-cmd "ssh" ;; "rsh"
+ "Program to use for remote shells.")
+
+(defun crontab-rsh-cmd ()
+ "Generate the rsh command. Redefine as needed."
+ (if crontab-user
+ (concat crontab-rsh-cmd " -l " (format "%s" crontab-user)) ;; str-ify
+ crontab-rsh-cmd) )
+
+(defun crontab-localhost-p (&optional host)
+ "True if this is the same HOST Emacs is on."
+ (or (null host)
+ (string= host "")
+ (string= host "localhost")
+ (string= host (system-name))) )
+
+(defun crontab-shell (host cmd out-buffer)
+ "On a possibly remote HOST, run CMD Output to OUT-BUFFER."
+ (when (not (crontab-localhost-p host))
+ (setq cmd (concat (crontab-rsh-cmd) " " host " " cmd)))
+ (shell-command cmd out-buffer) )
+
+;;;###autoload
+(defun crontab-mode ()
+ "Major mode for editing crontabs.
+Defines commands for getting and applying crontabs for hosts.
+Sets up command `font-lock-mode'.
+
+\\{crontab-mode-map}"
+ (interactive)
+ ;;
+ (kill-all-local-variables)
+ (setq mode-name "crontab")
+ (setq major-mode 'crontab-mode)
+ (use-local-map crontab-mode-map)
+ ;;
+ (setq comment-start "#")
+ (setq comment-start-skip "#+ *")
+ ;;
+ (make-local-variable 'font-lock-defaults)
+ (setq font-lock-defaults '(crontab-font-lock-keywords))
+ ;; Add to the end of the buffers save hooks.
+ (add-hook 'after-save-hook 'crontab-after-save t t)
+ ;;
+ (run-hooks 'crontab-mode-hook) )
+
+
+;;;###autoload
+(defun crontab-get (host)
+ "Get the crontab for the HOST into a buffer."
+ (interactive "sCrontab for host:")
+ (let ((cbn (generate-new-buffer-name (concat host crontab-suffix))))
+ (switch-to-buffer-other-window cbn)
+ (erase-buffer)
+ (crontab-mode)
+ (crontab-insert host)
+ (not-modified)
+ (setq crontab-host host)) )
+
+(defun crontab-insert (&optional host)
+ "Insert the crontab for the HOST into the current buffer."
+ (crontab-shell host "crontab -l" t) )
+
+(defun crontab-apply (&optional host)
+ "Apply the crontab to a HOST. The filesystem must be common."
+ (if (buffer-file-name)
+ (crontab-shell host (concat "crontab " (buffer-file-name)) nil)
+ (error "No filename for this buffer")))
+
+(defun crontab-save-and-apply ()
+ "Save and apply the buffer to the HOST."
+ (interactive)
+ (save-buffer)
+ (if (not crontab-apply-after-save) ;; Dont apply it twice.
+ (crontab-apply (crontab-host))) )
+
+(defun crontab-save-and-apply-to (host)
+ "Prompt for the HOST and apply the file."
+ (interactive "sApply to host:")
+ (setq crontab-host host) ;; remember the change
+ (crontab-save-and-apply) )
+
+(defun crontab-insert-ruler ()
+ "Insert a ruler with comments into the crontab."
+ (interactive)
+ (end-of-line)
+ (insert crontab-ruler) )
+
+(defun crontab-insert-local-var ()
+ "Insert the current values of buffer local variables."
+ (interactive)
+ (end-of-buffer)
+ (insert "
+" comment-start " Local " "Variables:
+" comment-start " mode: " (format "%s" (or mode-name "crontab")) "
+" comment-start " crontab-host: " (crontab-host) "
+" comment-start " crontab-apply-after-save: "
+(format "%s" crontab-apply-after-save) "
+" comment-start " End:
+") )
+
+(defun crontab-host ()
+ "Return the hostname as a string, defaulting to the local host.
+The variable `crontab-host' could be a symbol or a string."
+ (format "%s" (or crontab-host system-name)) )
+
+;;
+(defun crontab-after-save ()
+ "If `crontab-apply-after-save' is set, apply the crontab after a save."
+ (if crontab-apply-after-save (crontab-apply (crontab-host))) )
+
+(provide 'crontab-mode)
+(run-hooks 'crontab-load-hook)
+
+;;; crontab-mode.el ends here
--- /dev/null
+;;; dna-mode.el --- a major mode for editing dna sequences
+;;
+;; ~harley/share/emacs/pkg/dna/dna-mode.el ---
+;;
+;; $Id: dna-mode.el,v 1.40 2004/04/20 19:03:04 harley Exp $
+;;
+
+;; Author: Harley Gorrell <harley@panix.com>
+;; URL: http://www.mahalito.net/~harley/elisp/dna-mode.el
+;; License: GPL v2
+;; Keywords: dna, emacs, editing
+
+;;; Commentary:
+;; * A collection of functions for editing DNA sequences. It
+;; provides functions to make editing dna in Emacs easier.
+;;
+;; Dna-mode will:
+;; * Fontify keywords and line numbers in sequences.
+;; * Fontify bases when font-lock-mode is disabled.
+;; * Incrementally search dna over pads and numbers.
+;; * Complement and reverse complement a region.
+;; * Move over bases and entire sequences.
+;; * Detect sequence files by content.
+
+;;; Installation:
+;; --------------------
+;; Here are two suggested ways for installing this package.
+;; You can choose to autoload it when needed, or load it
+;; each time emacs is started. Put one of the following
+;; sections in your .emacs:
+;;
+;; ---Autoload:
+;; (autoload 'dna-mode "dna-mode" "Major mode for dna" t)
+;; (add-to-list
+;; 'auto-mode-alist
+;; '("\\.\\(fasta\\|fa\\|exp\\|ace\\|gb\\)\\'" . dna-mode))
+;; (add-hook 'dna-mode-hook 'turn-on-font-lock)
+;;
+;; ---Load:
+;; (setq dna-do-setup-on-load t)
+;; (load "/pathname/dna-mode")
+;;
+;; The dna-isearch-forward function (and isearch in general)
+;; is much more useful with something like the following:
+;; (make-face 'isearch)
+;; (set-face-background 'isearch "yellow")
+;; (setq-default search-highlight t)
+
+;;; History:
+;; 2003-03-16: Updated URL and contact info
+;; 2004-04-20: Added dna-color-bases-region to the keymap for Mike.
+
+;;; User customizable vars start here
+
+;;; Code:
+(defvar dna-mode-hook nil
+ "*Hook to setup `dna-mode'.")
+
+(defvar dna-mode-load-hook nil
+ "*Hook to run when `dna-mode' is loaded.")
+
+(defvar dna-setup-on-load nil
+ "*If not nil setup dna mode on load by running `dna-`add-hook's'.")
+
+;; Bases
+(defvar dna-valid-base-regexp
+ "[-*:acgtmrwsykvhdbxnACGTMRWSYKVHDBXN]"
+ "*A regexp which matches a single base.")
+
+(defvar dna-base-complement-list
+ '((?- . ?-) (?n . ?n) (?* . ?*) (?x . ?x) (?: . ?:) ; identity
+ (?a . ?t) (?c . ?g) (?g . ?c) (?t . ?a) ; single
+ (?m . ?k) (?r . ?y) (?w . ?w) (?s . ?s) (?y . ?r) (?k . ?m) ; double
+ (?v . ?b) (?h . ?d) (?d . ?h) (?b . ?v) ; triple
+ )
+ "*List of bases and their complements.
+Bases should be lowercase, as they are upcased when the `vector is made.")
+
+;; These are the colors used when coloring bases.
+(defvar dna-base-color-a "blue")
+(defvar dna-base-color-c "black")
+(defvar dna-base-color-g "green")
+(defvar dna-base-color-t "red")
+
+;; Dna-isearch
+(defvar dna-cruft-regexp "[* 0-9\t\n]"
+ "*Regexp to match cruft which may appear between bases.
+Skip over it during dna-motion and dna-isearch.")
+
+(defvar dna-isearch-case-fold-search t
+ "*Case fold dna-isearches if set.")
+
+;; Sequence
+(defvar dna-sequence-start-regexp
+ "^\\(>\\|ID\\|LOCUS\\|DNA\\)"
+ "A regexp which matches the start of a sequence.")
+
+;;; End of user customizable vars
+
+;;; Start of internal vars and code
+
+(defvar dna-base-complement-vector
+ (let ((c-vec (make-vector 256 nil))
+ (c-list dna-base-complement-list))
+ (while c-list
+ (aset c-vec (car (car c-list)) (cdr (car c-list)))
+ (aset c-vec (upcase (car (car c-list))) (upcase (cdr (car c-list))))
+ (setq c-list (cdr c-list)))
+ c-vec)
+ "A vector of upper and lower case bases and their complements.")
+
+;; I also use "Alt" as C-c is too much to type for cursor motions.
+(defvar dna-mode-map
+ (let ((map (make-sparse-keymap)))
+ ;; Ctrl bindings
+ (define-key map "\C-c\C-f" 'dna-forward-base)
+ (define-key map "\C-cf" 'dna-forward-base)
+ (define-key map "\C-c\C-b" 'dna-backward-base)
+ (define-key map "\C-cb" 'dna-backward-base)
+ (define-key map "\C-c\C-s" 'dna-isearch-forward)
+ (define-key map "\C-cs" 'dna-isearch-forward)
+ (define-key map "\C-cr" 'dna-reverse-complement-region)
+ (define-key map "\C-cc" 'dna-complement-region)
+ (define-key map "\C-c#" 'dna-count-bases-region)
+ (define-key map "\M-\C-h" 'dna-mark-sequence)
+ (define-key map "\M-\C-a" 'dna-beginning-of-sequence)
+ (define-key map "\M-\C-e" 'dna-end-of-sequence)
+ ;; base coloring
+ (define-key map "\C-cg" 'dna-color-bases-region)
+ (define-key map "\C-cl" 'font-lock-mode)
+ ;; XEmacs does not like the Alt bindings
+ (when (not (string-match "XEmacs" (emacs-version)))
+ (define-key map [A-right] 'dna-forward-base)
+ (define-key map [A-left] 'dna-backward-base)
+ (define-key map [A-up] 'dna-beginning-of-sequence)
+ (define-key map [A-down] 'dna-end-of-sequence)
+ (define-key map [?\A-\C-s] 'dna-isearch-forward))
+ map)
+ "The local keymap for `dna-mode'.")
+
+;;;###autoload
+(defun dna-mode ()
+ "Major mode for editing DNA sequences.
+
+This mode also customizes isearch to search over line breaks.
+Use \\[universal-argument] Number as a prefix to dna-forward-base to move that
+many bases. This skips line breaks and spaces.
+
+dna-color-bases-region disables font-lock-mode automaticly
+as they cant work together. \\[dna-color-bases-region] turns font-lock-mode back on.
+
+\\{dna-mode-map}"
+ (interactive)
+ ;;
+ (kill-all-local-variables)
+ (setq mode-name "dna")
+ (setq major-mode 'dna-mode)
+ (use-local-map dna-mode-map)
+ ;;
+ (make-local-variable 'font-lock-defaults)
+ (setq font-lock-defaults '(dna-font-lock-keywords))
+ ;;
+ (make-local-variable 'dna-valid-base-regexp)
+ (make-local-variable 'dna-sequence-start-regexp)
+ (make-local-variable 'dna-cruft-regexp)
+ (make-local-variable 'dna-isearch-case-fold-search)
+ ;;
+ (run-hooks 'dna-mode-hook))
+
+;; Keywords
+;; Todo: Seperate the keywords into a list for each format, rather
+;; than one for all.
+(defvar dna-font-lock-keywords
+ '(
+ ;; Fasta
+ ("^\\(>\\)\\([-_.|a-zA-Z0-9]+\\)\\([ \t]+.*\\)?"
+ (1 font-lock-keyword-face)
+ (2 font-lock-function-name-face)
+ (3 font-lock-comment-face nil t))
+
+ ;; Exp
+ ("^\\(ID\\) +\\([-_.a-zA-Z_0-9]+\\)"
+ (1 font-lock-keyword-face) (2 font-lock-function-name-face))
+ ("^\\(CC\\|SQ\\)\\([ \t]\\(.*\\)\\)?$"
+ (1 font-lock-keyword-face) (3 font-lock-comment-face nil t))
+ ("^\\(\\sw\\sw\\)[ \t]"
+ (1 font-lock-keyword-face))
+ ("^\\(//\\)"
+ (1 font-lock-keyword-face))
+
+ ;; Ace (phrap output)
+ ("^\\(DNA\\|Sequence\\|BaseQuality\\) +\\([-_.a-zA-Z_0-9]+\\)"
+ (1 font-lock-keyword-face) (2 font-lock-function-name-face))
+
+ ;; Genbank
+ ("^\\(LOCUS\\) +\\([-_.a-zA-Z_0-9]+\\)";; are '-_.' allowed?
+ (1 font-lock-keyword-face) (2 font-lock-function-name-face))
+ "ORIGIN"
+
+ ; More genbank keywords...
+ "ACCESSION" "AUTHORS" "AUTHORS" "BASE COUNT" "DEFINITION"
+ "FEATURES" "JOURNAL" "JOURNAL" "KEYWORDS" "MEDLINE" "NID"
+ "ORGANISM" "REFERENCE" "SEGMENT" "SOURCE" "TITLE"
+
+ ;; line numbers...
+ ("^[ \t]*\\([0-9]+\\)"
+ (1 font-lock-string-face))
+
+ ;; others...?
+ )
+ "Expressions to hilight in `dna-mode'.")
+
+
+;;; Setup functions
+(defun dna-find-file-func ()
+ "Invoke `dna-mode' if the buffer look like a sequence.
+and another mode is not active.
+This function is added to `find-file-hooks'."
+ (if (and (eq major-mode 'fundamental-mode)
+ (looking-at dna-sequence-start-regexp))
+ (dna-mode)))
+
+;;;###autoload
+(defun dna-add-hooks ()
+ "Add a default set of dna-hooks.
+These hooks will activate `dna-mode' when visiting a file
+which has a dna-like name (.fasta or .gb) or whose contents
+looks like dna. It will also turn enable fontification for `dna-mode'."
+ (add-hook 'dna-mode-hook 'turn-on-font-lock)
+ (add-hook 'find-file-hooks 'dna-find-file-func)
+ (add-to-list
+ 'auto-mode-alist
+ '("\\.\\(fasta\\|fa\\|exp\\|ace\\|gb\\)\\'" . dna-mode)))
+
+;; Setup hooks on request when this mode is loaded.
+(if dna-setup-on-load
+ (dna-add-hooks))
+
+(defun dna-next-char-func ()
+ "Should never be called. Overridden in `dna-forward-base'."
+ (error "This shouldnt have been called"))
+
+;; Motion
+(defun dna-forward-base (count)
+ "Move forward COUNT bases. Move backward if negative.
+Skip over dna-isearch-cruft. Stop on non-base or
+non-whitespace characters."
+ (interactive "p")
+ (let ((c 0)
+ (abscount (abs count))
+ (dir (if (< count 0) -1 1))
+ dna-next-char-func
+ bstr)
+ ;;
+ (fset 'dna-next-char-func (if (< dir 0) 'preceding-char 'following-char))
+ ;;
+ (while (< c abscount)
+ (setq bstr (char-to-string (dna-next-char-func)))
+ (cond
+ ((string-match dna-valid-base-regexp bstr)
+ (forward-char dir)
+ (setq c (1+ c)))
+ ((string-match dna-cruft-regexp bstr)
+ (forward-char dir))
+ (t
+ (message "Moved %d bases forward." c)
+ (setq abscount c)))) ; stop the while
+
+ ;; Move over trailing junk when moving forward
+ (if (= dir 1)
+ (while (string-match dna-cruft-regexp
+ (char-to-string (dna-next-char-func)))
+ (forward-char dir))
+ )
+ ;; return the distance moved
+ (* dir abscount)))
+
+;; aaaaaaaaaa cccccccccc | gggggggggg tttttttttt
+
+(defun dna-backward-base (count)
+ "Move backward COUNT bases. See `dna-forward-base'."
+ (interactive "p")
+ (dna-forward-base (- count)))
+
+(defun dna-beginning-of-sequence ()
+ "Move the start of the sequence or the buffer."
+ (interactive)
+ (goto-char
+ (or
+ (search-backward-regexp dna-sequence-start-regexp (point-min) t)
+ (point-min))))
+
+(defun dna-end-of-sequence ()
+ "Move to the end of the sequence or the buffer."
+ (interactive)
+ (end-of-line)
+ (skip-syntax-forward "-")
+ (let ((seqstart
+ (search-forward-regexp dna-sequence-start-regexp (point-max) t)))
+ (if seqstart (progn
+ (goto-char seqstart)
+ (beginning-of-line))
+ (goto-char (point-max)))))
+
+(defun dna-mark-sequence ()
+ "Put point at the beginning of a sequence, mark at end."
+ (interactive)
+ (dna-end-of-sequence)
+ (set-mark (point))
+ (dna-beginning-of-sequence))
+
+(defun dna-count-bases-region (d-start d-end)
+ "Count the number of bases in the region D-START to D-END.
+Echos the number of bases counted.
+If an invalid base is found, stops on the base and signals an error."
+ (interactive "r")
+ (let ((basecount 0))
+ (goto-char d-start)
+ (while (< (point) d-end)
+ (cond
+ ((looking-at dna-valid-base-regexp)
+ (setq basecount (1+ basecount))
+ (forward-char 1))
+ ((looking-at dna-cruft-regexp)
+ (forward-char 1))
+ (t
+ (error "Bad base found. '%s'"
+ (buffer-substring (point) (1+ (point)))))
+ ))
+ (message "There are %d bases in the region." basecount)
+ basecount))
+
+;;; reverse and complement
+(defun dna-complement-base-list (base)
+ "Complement the BASE using a list based method.
+Returns the complement of the base.
+It can also be used to test if the character is a base,
+as all bases should have a complement."
+ (cdr (assq base dna-base-complement-list)))
+
+(defun dna-complement-base (base)
+ "Complement a BASE using a vector based method.
+See `dna-complement-base-list' for more info."
+ (aref dna-base-complement-vector base))
+
+(defun dna-complement (base)
+ "Look up the complement of the BASE and print a message.
+Handy for us CS types."
+ (interactive "cComplement of base:")
+ (message "Complement of '%c' is '%c'." base (dna-complement-base base)))
+
+(defun dna-complement-region (r-start r-end)
+ "Complement a region of bases from R-START to R-END.
+Complement a region of the buffer by deleting it and
+inserting the complements, base by base. Non-bases are
+passed over unchanged."
+ (interactive "r")
+ (let (r-string r-length r-point r-base r-cbase)
+ (goto-char r-start)
+ (setq r-string (buffer-substring-no-properties r-start r-end))
+ (setq r-length (length r-string))
+ (delete-region r-start r-end)
+ (setq r-point 0)
+ (while (< r-point r-length)
+ (setq r-base (aref r-string r-point))
+ (setq r-cbase (dna-complement-base r-base))
+ (insert (if r-cbase r-cbase r-base))
+ (setq r-point (1+ r-point)))))
+
+;;;###autoload
+(defun dna-reverse-complement-region (r-start r-end)
+ "Reverse complement a region of dna from R-START to R-END.
+Works by deleting the region and inserting bases reversed
+and complemented, while entering non-bases in the order
+found."
+ (interactive "r")
+ (let (r-string r-length r-base r-cbase r-point r-mark)
+ (goto-char r-start)
+ (setq r-string (buffer-substring-no-properties r-start r-end))
+ (setq r-length (length r-string))
+ (setq r-mark (1- r-length))
+ (setq r-point 0)
+
+ ;; goodbye
+ (delete-region r-start r-end)
+
+ ;; insert the bases from back to front base by base
+ ;; insert non-bases from front to back to preserve spacing
+ (while (< r-point r-length)
+ (setq r-base (aref r-string r-point))
+ (setq r-cbase (dna-complement-base r-base))
+ (if r-cbase
+ (progn
+ ;; it is a base. find the reverse and complement it
+ (while (not (dna-complement-base (aref r-string r-mark)))
+ (setq r-mark (1- r-mark)))
+ (insert (dna-complement-base (aref r-string r-mark)))
+ (setq r-mark (1- r-mark)) )
+ ;; not a base, no change
+ (insert r-base))
+ (setq r-point (1+ r-point)))))
+
+;; format
+(defun dna-guess-format-func ()
+ "Guess the format of the sequence the point is at or after.
+Returns the format or nil."
+ (save-excursion
+ (end-of-line)
+ (dna-beginning-of-sequence)
+ (cond
+ ((looking-at "^>") 'fasta)
+ ((looking-at "^DNA") 'phrap)
+ ((looking-at "^ID") 'exp)
+ (t nil))))
+
+(defun dna-guess-format ()
+ "Guess and print the format of the sequence."
+ (interactive)
+ (message "%s" (dna-guess-format-func)))
+
+;;; dna-isearch stuff
+(defun dna-isearch-mangle-str (str)
+ "Mangle the string STR into a regexp to search over cruft in sequence.
+Inserts a regexp between each base which matches sequence formatting cruft.
+For example, if `dna-cruft-regexp' is '[ ]',
+the search string 'acgt' would transformed into 'a[ ]*c[ ]*g[ ]*t[ ]*'"
+ (let ((i 0) (out ""))
+ (while (< i (length str))
+ (setq out (concat out (substring str i (1+ i)) dna-cruft-regexp "*"))
+ (setq i (1+ i)))
+ out))
+
+(defadvice isearch-message-prefix (around dna-isearch-ismp)
+ "Set the isearch prompt string to show dna search is active.
+This serves as a warning that the string is being mangled."
+ ad-do-it
+ (setq ad-return-value (concat "DNA " ad-return-value)))
+
+(defadvice isearch-search (around dna-isearch-iss)
+ "The advice used to mangle the search string in isearch."
+ (let ((isearch-regexp t)
+ ;; force case folding
+ (isearch-case-fold-search dna-isearch-case-fold-search)
+ (isearch-string (dna-isearch-mangle-str isearch-string)) )
+ ad-do-it))
+
+;;;###autoload
+(defun dna-isearch-forward ()
+ "Isearch forward on dna sequence.
+Enable the `dna-mode' search string mangling advice and start the search."
+ (interactive)
+ ;; Enable the prompt
+ (ad-enable-advice 'isearch-message-prefix 'around 'dna-isearch-ismp)
+ (ad-activate 'isearch-message-prefix)
+ ;; Enable the mangling
+ (ad-enable-advice 'isearch-search 'around 'dna-isearch-iss)
+ (ad-activate 'isearch-search)
+
+ ;; run the search
+ (isearch-forward)
+
+ ;;
+ (ad-disable-advice 'isearch-message-prefix 'around 'dna-isearch-ismp)
+ (ad-activate 'isearch-message-prefix)
+ ;;
+ (ad-disable-advice 'isearch-search 'around 'dna-isearch-iss)
+ (ad-activate 'isearch-search))
+
+;;; Work with columns of sequences.
+
+(defun dna-column-select-func ()
+ "Return the start and end of the column as a cons.
+Point is moved forward one."
+ (let (s m e)
+ (setq m (point))
+ ;; work our way up
+ (while (looking-at dna-valid-base-regexp)
+ (setq s (point))
+ (previous-line 1))
+ (goto-char m)
+ ;; work our way down
+ (while (looking-at dna-valid-base-regexp)
+ (setq e (point))
+ (next-line 1))
+ (goto-char m)
+ ;; return the start and end of the column
+ (cons s (1+ e))))
+
+(defun dna-column-select ()
+ "Select the current column of text.
+Sets the mark at the top and the point at the bottom of a non-blank column."
+ (interactive)
+ (let ((se (dna-column-select-func)))
+ (goto-char (car se))
+ (push-mark)
+ (goto-char (cdr se))))
+
+(defvar dna-column-pad "*"
+ "Character to use when inserting a column of pads.")
+
+(defun dna-column-insert-pad ()
+ "Insert a column of pads."
+ (interactive)
+ (save-excursion
+ (let ((se (dna-column-select-func)))
+ (string-rectangle (car se) (cdr se) dna-column-pad))))
+
+(defun dna-column-delete ()
+ "Delete the current column of dna."
+ (interactive)
+ (save-excursion
+ (let ((se (dna-column-select-func)))
+ (kill-rectangle (car se) (cdr se)))))
+
+;;; Per base colors
+
+(defun dna-base-color-make-faces (&optional force)
+ "Build a face to display bases with. FORCE remakes the faces."
+ (when (or (not (facep 'dna-face-t)) force)
+ (let ((base-list '("a" "c" "g" "t"))
+ base base-face)
+ (while base-list
+ (setq base (car base-list))
+ (setq base-face (intern (concat "dna-base-face-" base)))
+ (make-face base-face)
+ (set-face-foreground
+ base-face (symbol-value (intern (concat "dna-base-color-" base))))
+ (setq base-list (cdr base-list))))))
+
+;; Make faces on load
+(dna-base-color-make-faces t)
+
+(defvar dna-color-bases-auto t
+ "Automaticly deactivate `font-lock-mode' when `dna-color-bases' is run.
+See dna-color-bases for details.")
+;; (setq dna-color-bases-auto t)
+
+(defun dna-color-bases-region (s e)
+ "Color the bases in the region S to E.
+NOTE: The function `font-lock-mode' will undo the work of this
+function if activated. Disable it before using this
+function. If `dna-color-bases-auto' is set then `font-lock-mode'
+is deactivated automatically."
+ (interactive "r")
+ (if (and dna-color-bases-auto font-lock-mode)
+ (font-lock-mode -1))
+ (if font-lock-mode
+ (error "Font-lock-mode is on -- deactivate it"))
+ (save-excursion
+ (let (c)
+ (goto-char s)
+ (while (< s e)
+ (setq c (downcase (char-after s)))
+ (cond
+ ((eq c ?a)
+ (set-text-properties s (+ s 1) '(face dna-base-face-a)))
+ ((eq c ?c) (+ s 1)
+ (set-text-properties s (+ s 1) '(face dna-base-face-c)))
+ ((eq c ?g) (+ s 1)
+ (set-text-properties s (+ s 1) '(face dna-base-face-g)))
+ ((eq c ?t) (+ s 1)
+ (set-text-properties s (+ s 1) '(face dna-base-face-t)))
+ (t nil))
+ (setq s (+ s 1))))))
+
+(defun dna-uncolor-bases-region (s e)
+ "Uncolor the bases from S to E."
+ (interactive "r")
+ (remove-text-properties s e '(face nil)))
+
+;;; Functions for me.
+
+;; I like to datestamp sequences I work with.
+(defvar dna-timestamp-format "%Y%m%d"
+ "Format of the time stamp which `dna-timestamp-seq' uses.")
+
+(defun dna-timestamp-seq ()
+ "Insert the current date into the sequence.
+Assumes fasta format."
+ (interactive)
+ (end-of-line)
+ (dna-beginning-of-sequence)
+ (end-of-line)
+ (insert " " (format-time-string dna-timestamp-format (current-time))))
+
+;; done loading
+(run-hooks 'dna-mode-load-hook)
+(provide 'dna-mode)
+
+;;; dna-mode.el ends here
--- /dev/null
+;;; ecasound.el --- Interactive and programmatic interface to Ecasound
+
+;; Copyright (C) 2001, 2002 Mario Lang
+
+;; Author: Mario Lang <mlang@delysid.org>
+;; Keywords: audio, ecasound, eci, comint, process, pcomplete
+;; Version: 0.8.2
+
+;; This file is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; This file is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; This file implements several aspects of ecasound use:
+;;
+;; * A derived-major-mode, from comint mode for an inferior ecasound
+;; process (ecasound-aim-mode). Complete with context sensitive
+;; completion and interactive features to control the current process
+;; using ECI.
+;;
+;; * Ecasound Control Interface (ECI) library for programmatic control
+;; of a Ecasound process. This allows you to write Ecasound batch
+;; jobs in Emacs-Lisp with Lisp functions and return values. Have a
+;; look at eci-example and ecasound-normalize.
+;;
+;; * ecasound-ewf-mode, a mode for editing .ewf files.
+;;
+;;
+;; Usage:
+;;
+;; You need at least ecasound 2.2.0 for this file to work properly.
+;;
+;; Put ecasound.el in your load-path and require it in your .emacs.
+;; Set `ecasound-program' to the path to your ecasound executable.
+;;
+;; (setq load-path (cons "/home/user/elisp")
+;; (require 'ecasound)
+;; (setq ecasound-program "/home/user/bin/ecasound"
+;; eci-program "/home/user/bin/ecasound")
+;;
+;; To set ecasound startup options use
+;;
+;; M-x ecasound-customize-startup RET
+;;
+;; Then use M-x ecasound RET to invoke an inferior ecasound process.
+;;
+;; For programmatic use of the ECI API, have a look at `eci-init',
+;; `eci-command' and in general the eci-* namespace.
+;;
+;; Compatibility:
+;;
+;; This file only works with GNU Emacs 21. I've invested some minimal efforts
+;; to get it working with XEmacs, but have so far failed to succeed.
+;; Motivation isn't very high to get it working with XEmacs since I personally
+;; never use it. So if you would like to use ecasound.el under XEmacs, you
+;; will have ttodo
+;; M-x toggle-debug-on-error RET
+;; and see what you can figure out. I'm happy to receive useful suggestions.
+;;
+;; Todo:
+;;
+;; * Find a better way to do status info fetching...
+;; * Add more conditions to the menu.
+;; * Use map-xxx-list data in the ecasound-copp widget. This means we
+;; need to merge cop-status and map-cop-list data somehow or have
+;; the cop-editor fetch hints from map-cop/ladpsa/preset-list.
+;; * Make `ecasound-signalview' faster, and allow to invoke it on already
+;; opened sessions.
+;; * Fix the case where ecasound sends output *after* the prompt.
+;; This is tricky! Fixed for internal parsing, probably will leave
+;; like that for interactive use, not worth the trouble...
+;; * Copy documentation for ECI commands into eci-* docstrings and menu
+;; :help keywords.
+;; * Expand the menu.
+;; * Bind most important interactive functions in ecasound-iam-mode-map
+;; (which layout to use?)
+
+;;; History:
+;;
+;; Version: 0.8.2
+;;
+;; * Added quite some missing docstrings.
+;; * New variable `ecasound-last-command-alist'. Use that to do fancy stuff
+;; to certain commands return values.
+;; * New variable `ecasound-type-alist'. Normally you should not need to
+;; change this, but it's nice to have it configurable.
+;; * New function `eci-is-valid-p'. Rationale is that nil as return
+;; value of a ECI command should indicate an error. So this function
+;; with a -p suffix to use as a predicate.
+;; * New variable `ecasound-parent' holds the parent buffer in a daemon buffer.
+;; * New variables ecasound-timer-flag&interval.
+;; * Renamed `eci-output-filter' to `ecasound-output-filter'.
+;; * New variable ecasound-mode|header-line-format.
+;; * `ecasound-cop-edit' now uses cop-set instead of
+;; cop-select+copp-select+copp-set to update values.
+;; * Fixed multiple-argument handling. They are separated with ',', not
+;; with a space.
+;; * New variable ecasound-sending-command, used to prevent the background
+;; timer from coliding with other ECI requests.
+;;
+;; Version: 0.8.1
+;;
+;; * Make ai|ao|cs-forward|rewind use ai|ao|cs-selected in the prompt
+;; string of the interactive spec.
+;; * New keymaps ecasound-audioin|audioout-map.
+;; Now you can be very quick:
+;; M-x ecasound RET M-i a <select file> RET M-o d start RET
+;; * New menu ecasound-iam-ai|ao-menu.
+;; * defeci for ai|ao-add|forward|iselect|list|rewind|select|selected
+;; * Deleted `ecasound-buffer-name' and `eci-buffer-name' and replaced
+;; calls to `make-comint-in-buffer' with `make-comint'.
+;; * Extended defeci's :cache and :cache-doc to defvar the variable.
+;; * Cleaned up some old alias definitions.
+;;
+;; Version: 0.8.0
+;;
+;; * New custom type ecasound-args, which is now used for `ecasound-arguments'
+;; and `eci-arguments'.
+;; * If :cache is specified, also try to find a cached version in daemon-buffer
+;; if available.
+;; * Added :alias keyword to defeci. Delete defecialias.
+;; * Added ":pcomplete doc" to several defeci calls.
+;; * ecasound-cop|ctrl-add deleted and merged with the interactive spec of
+;; eci-cop|ctrl-add. Now if prefix arg (C-u) is given, prompt for plain
+;; string, otherwise prompt with completion. Also changed binding
+;; in ChainOp menu.
+;; * `ecasound-messages': variable deleted.
+;; * `ecasound-arguments': Now handles -d:nnn properly.
+;; * Many other minor tweaks and fixes.
+;;
+;; Version: 0.7.9
+;;
+;; * Cleanup and extend `defeci', now handles keyword :cache and :pcomplete.
+;; Lots of `defeci'-caller updates, and additions.
+;; * Extended `ecasound-arguments' customize defition to handle --daemon,
+;; --daemon-port:nnn, -n:name and -b:size. New interactive function
+;; `ecasound-customize-startup', also bound in "Ecasound menu."
+;; * Added status-information fetching via timer-function. Puts
+;; info in mode-line as well as header-line. (warning, this feature is still
+;; a bit unstable.)
+;; * New macro `eci-hide-output' used to redirect action to `ecasound-daemon'
+;; if possible. Several completion-fascilities updated to use it.
+;; * Various other fixes.
+;;
+;; Version: 0.7.8
+;;
+;; * Fix bug in "cop-add -el:" completion.
+;; * Made `ecasound-format-arg' a bit prettier.
+;; * Add --daemon support. If --daemon is set in `ecasound-arguments',
+;; ecasound-iam-mode will take advantage of that and initialize a
+;; `ecasound-daemon' channel, as well as a periodic timer to update the
+;; mode-line. M-: (display-buffer ecasound-daemon) RET to view its contents.
+;;
+;; Version: 0.7.7
+;;
+;; * Fixed hangup if a Stringlist ('S') returned a empty list.
+;; * Added keybindings. See C-h m for details. Still alot missing.
+;; * Added cs-forward and cs-rewind. Can be used interactively, or
+;; prompt for value. With no prefix arg, prompts for value, with
+;; prefix arg, uses that. Example: C-u M-c M-s f forwards the chainsetup
+;; by 4 seconds, M-9 M-c M-s f forwards nine seconds ...
+;; * Fixed field-no-longer-editable bug when +/- is used in
+;; ecasound-cop-editor (thanks Per). This also makes the slider useful again.
+;; * Got rid of ecasound-prompt assumptions in `eci-parse' and `eci-command'.
+;; * Make the eci-command family work with --daemon tcp/ip connections.
+;; (no code for initialising daemon stuff yet, but eci-* commands
+;; work fine with tcp/ip conns (tested manually).
+;; * `eci-parse' deleted and merged with `eci-output-filter'.
+;;
+;; Version: 0.7.6
+;;
+;; * Various minor bugfixes and enhancements.
+;; * Implemented ecasignalview as `ecasound-signalview' directly in Lisp.
+;; This is another demonstration that ECI was really a Good Thing(tm)!
+;; * Changed defeci to make it look more like a defun.
+;; * Removed eci-process-*-register handling completely. Rationale is
+;; that the map-*-list stuff is actually much more uniform and offers more
+;; info.
+;; * Rewrote `pcomplete/ecasound-iam-mode/cop-add' to use map-*-list.
+;; * Rewrote `ecasound-ctrl-add' using map-ctrl-list instead of ctrl-register
+;; and `ecasound-read-copp'.
+;; * Rewrote `ecasound-cop-add' using map-cop|ladspa|preset-list.
+;; * New function `eci-process-map-list' which processes the new map-xxx-list
+;; output into a wellformed Lisp list.
+;; * `ecasound-iam-commands' is now filled using int-cmd-list.
+;; * cop-map-list handling. Used in `ecasound-cop-add' now. New function
+;; `ecasound-read-copp' uses the now available default value.
+;;
+;; Version: 0.7.5
+;;
+;; * Added ctrl-register parsing support and `ecasound-ctrl-add'.
+;; * Added preset-register support (so far only for cop-add completion)
+;; * Fixed cop-status parsing bug which caused `ecasound-cop-edit' to not
+;; work in some cases.
+;; * New macro defeci which handles defining ECI commands in lisp.
+;; * Several other minor tweaks and fixes.
+;;
+;; Version: 0.7.4
+;;
+;; * Fixed `eci-command' once again, it blocked for nearly every call... :(
+;; * Fixed ecasound-cop-add in the ladspa case.
+;;
+;; Version: 0.7.3
+;;
+;; * Fixed missing require.
+;;
+;; Version: 0.7.2
+;;
+;; * Integrated ladspa-register into ecasound-cop-add
+;; Now we've a very huge list to select from using completion.
+;; * Some little cleanups.
+;; * Fixed ecasound-cop-add to actually add the ':' between name and args.
+;; * Removed the slider widget for now from the :format property of
+;; ecasound-copp.
+;; * Added `ecasound-messages' for a nice customisable interface to
+;; loglevels, strangely, cvs version doesnt seem to recognize
+;; -d:%d
+;;
+;; Version: 0.7.1
+;;
+;; * Created a slider widget. It's not flawless, but it works!
+;;
+
+;;; Code:
+
+(require 'cl)
+(require 'comint)
+(require 'easymenu)
+(require 'pcomplete)
+(require 'widget)
+(require 'wid-edit)
+
+(defgroup ecasound nil
+ "Ecasound is a software package designed for multitrack audio processing.
+It can be used for simple tasks like audio playback, recording and format
+conversions, as well as for multitrack effect processing, mixing, recording
+and signal recycling. Ecasound supports a wide range of audio inputs, outputs
+and effect algorithms. Effects and audio objects can be combined in various
+ways, and their parameters can be controlled by operator objects like
+oscillators and MIDI-CCs.
+
+Variables in this group affect inferior ecasound processes started from
+within Emacs using the command `ecasound'.
+
+See the subgroup `eci' for settings which affect the programmatic interface
+to ECI."
+ :prefix "ecasound-"
+ :group 'processes)
+
+(define-widget 'ecasound-cli-arg 'string
+ "A Custom Widget for a command-line argument."
+ :format "%t: %v%d"
+ :string-match 'ecasound-cli-arg-string-match
+ :match 'ecasound-cli-arg-match
+ :value-to-internal
+ (lambda (widget value)
+ (when (widget-apply widget :string-match value)
+ (match-string 1 value)))
+ :value-to-external
+ (lambda (widget value)
+ (format (widget-apply widget :arg-format) value)))
+
+(defun ecasound-cli-arg-match (widget value)
+ (when (stringp value)
+ (widget-apply widget :string-match value)))
+
+(defun ecasound-cli-arg-string-match (widget value)
+ (string-match
+ (format (concat "^" (regexp-quote (widget-get widget :arg-format)))
+ (concat "\\(" (widget-get widget :pattern) "\\)"))
+ value))
+
+(define-widget 'ecasound-daemon-port 'ecasound-cli-arg
+ "A Custom Widget for the --daemon-port:port argument."
+ :pattern ".*"
+ :arg-format "--daemon-port:%s")
+
+(define-widget 'ecasound-chainsetup-name 'ecasound-cli-arg
+ "A Custom Widget for the -n:chainsetup argument."
+ :arg-format "-n:%s"
+ :doc "Sets the name of chainsetup.
+If not specified, defaults either to \"command-line-setup\" or to the file
+name from which chainsetup was loaded. Whitespaces are not allowed."
+ :format "%t: %v%h"
+ :pattern ".*"
+ :tag "Chainsetup name")
+
+(define-widget 'ecasound-buffer-size 'ecasound-cli-arg
+ "A Custom Widget for the -b:buffer size argument."
+ :arg-format "-b:%s"
+ :doc "Sets the size of buffer in samples (must be an exponent of 2).
+This is quite an important option. For real-time processing, you should set
+this as low as possible to reduce the processing delay. Some machines can
+handle buffer values as low as 64 and 128. In some circumstances (for
+instance when using oscillator envelopes) small buffer sizes will make
+envelopes act more smoothly. When not processing in real-time (all inputs
+and outputs are normal files), values between 512 - 4096 often give better
+results."
+ :format "%t: %v%h"
+ :pattern "[0-9]+"
+ :tag "Buffer size")
+
+(define-widget 'ecasound-debug-level 'set
+ "Custom widget for the -d:nnn argument."
+ :arg-format "-d:%s"
+ :args '((const :tag "Errors" 1)
+ (const :tag "Info" 2)
+ (const :tag "Subsystems" 4)
+ (const :tag "Module names" 8)
+ (const :tag "User objects" 16)
+ (const :tag "System objects" 32)
+ (const :tag "Functions" 64)
+ (const :tag "Continuous" 128)
+ (const :tag "EIAM return values" 256))
+ :doc "Set the debug level"
+ :match 'ecasound-cli-arg-match
+ :pattern "[0-9]+"
+ :string-match 'ecasound-cli-arg-string-match
+ :tag "Debug level"
+ :value-to-external
+ (lambda (widget value)
+ (format (widget-get widget :arg-format)
+ (number-to-string (apply #'+ (widget-apply widget :value-get)))))
+ :value-to-internal
+ (lambda (widget value)
+ (when (widget-apply widget :string-match value)
+ (let ((level (string-to-number (match-string 1 value)))
+ (levels (nreverse
+ (mapcar (lambda (elt) (car (last elt)))
+ (widget-get widget :args)))))
+ (if (or (> level (apply #'+ levels)) (< level 0))
+ (error "Invalid debug level %d" level)
+ (delq nil
+ (mapcar (lambda (elem)
+ (when (eq (/ level elem) 1)
+ (setq level (- level elem))
+ elem)) levels)))))))
+
+(define-widget 'ecasound-args 'set
+ ""
+ :args '((const :tag "Start ecasound in interactive mode" "-c")
+ (const :tag "Print all debug information to stderr"
+ :doc "(unbuffered, plain output without ncurses)"
+ "-D")
+ (ecasound-debug-level)
+ (list :format "%v" :inline t
+ (const :tag "Allow remote connections:" "--daemon")
+ (ecasound-daemon-port :tag "Daemon port" "--daemon-port:2868"))
+ (ecasound-buffer-size "-b:1024")
+ (ecasound-chainsetup-name "-n:eca-el-setup")
+ (const :tag "Truncate outputs" :format "%t\n%h"
+ :doc "All output objects are opened in overwrite mode.
+Any existing files will be truncated."
+ "-x")
+ (const :tag "Open outputs for updating"
+ :doc "Ecasound opens all outputs - if target format allows it - in readwrite mode."
+ "-X")
+ (repeat :tag "Others" :inline t (string :tag "Argument"))))
+
+(defcustom ecasound-arguments '("-c" "-d:259" "--daemon" "--daemon-port:2868"
+ "-n:eca-el-setup")
+ "*Command line arguments used when starting an ecasound process."
+ :group 'ecasound
+ :type 'ecasound-args)
+
+(defun ecasound-daemon-port ()
+ "Return the port number defined in `ecasound-arguments'."
+ (let ((elem (member* "^--daemon-port:\\(.*\\)" ecasound-arguments
+ :test #'string-match)))
+ (if elem
+ (match-string 1 (car elem)))))
+
+(defun ecasound-customize-startup ()
+ "Customize ecasound startup arguments."
+ (interactive)
+ (customize-variable 'ecasound-arguments))
+
+(defcustom ecasound-program "/home/mlang/bin/ecasound"
+ "*Ecasound's executable.
+This program is executed when the user invokes \\[ecasound]."
+ :group 'ecasound
+ :type 'file)
+
+(defcustom ecasound-prompt-regexp "^ecasound[^>]*> "
+ "Regexp to use to match the prompt."
+ :group 'ecasound
+ :type 'regexp)
+
+(defcustom ecasound-parse-cleanup-buffer t
+ "*Indicates if `ecasound-output-filter' should cleanup the buffer.
+This means the loglevel, msgsize and return type will get removed if
+parsed successfully."
+ :group 'ecasound
+ :type 'boolean)
+
+(defcustom ecasound-error-hook nil
+ "*Called whenever a ECI error happens."
+ :group 'ecasound
+ :type 'hook)
+
+(defcustom ecasound-message-hook '(ecasound-print-message)
+ "*Hook called whenever a message except loglevel 256 (eci) is received.
+Arguments are LOGLEVEL and STRING."
+ :group 'ecasound
+ :type 'hook)
+
+(defun ecasound-print-message (level msg)
+ "Simple function which prints every message regardless which loglevel.
+Argument LEVEL is the debug level."
+ (message "Ecasound (%d): %s" level msg))
+
+(defface ecasound-error-face '((t (:foreground "White" :background "Red")))
+ "Face used to highlight errors."
+ :group 'ecasound)
+
+(defcustom ecasound-timer-flag t
+ "*If non-nil, fetch status information in background."
+ :group 'ecasound
+ :type 'boolean)
+
+(defcustom ecasound-timer-interval 2
+ "*Defines how often status information should be fetched."
+ :group 'ecasound
+ :type 'number)
+
+(defcustom ecasound-mode-line-format
+ '("-"
+ mode-line-frame-identification
+ mode-line-buffer-identification
+ eci-engine-status " "
+ ecasound-mode-string
+ " %[("
+ (:eval (mode-line-mode-name))
+ mode-line-process
+ minor-mode-alist
+ "%n"
+ ")%]--"
+ (line-number-mode "L%l--")
+ (column-number-mode "C%c--")
+ (-3 . "%p")
+ "-%-")
+ "*Mode Line Format used in `ecasound-iam-mode'."
+ :group 'ecasound
+ :type '(repeat
+ (choice
+ string
+ variable
+ (cons integer string)
+ (list :tag "Evaluate" (const :value :eval) sexp)
+ (repeat sexp))))
+
+(defcustom ecasound-header-line-format nil
+ "*If non-nil, defines the header line format for `ecasound-iam-mode' buffers."
+ :group 'ecasound
+ :type 'sexp)
+
+(defvar ecasound-sending-command nil
+ "Non-nil if `eci-command' is running.")
+
+(make-variable-buffer-local
+ (defvar ecasound-daemon nil
+ "If non-nil, this variable holds the buffer object of a daemon channel."))
+
+(make-variable-buffer-local
+ (defvar ecasound-parent nil
+ "If non-nil, this variable holds the buffer object of a daemon parent."))
+
+(make-variable-buffer-local
+ (defvar ecasound-daemon-timer nil))
+
+(defvar ecasound-chain-map nil
+ "Keymap used for Chain operations.")
+(define-prefix-command 'ecasound-chain-map)
+(define-key 'ecasound-chain-map "a" 'eci-c-add)
+(define-key 'ecasound-chain-map "c" 'eci-c-clear)
+(define-key 'ecasound-chain-map "d" 'eci-c-deselect)
+(define-key 'ecasound-chain-map "m" 'eci-c-mute)
+(define-key 'ecasound-chain-map "x" 'eci-c-remove)
+(define-key 'ecasound-chain-map (kbd "M-s") 'ecasound-cs-map)
+(define-key 'ecasound-chain-map (kbd "M-o") 'ecasound-cop-map)
+(defvar ecasound-cop-map nil
+ "Keymap used for Chain operator operations.")
+(define-prefix-command 'ecasound-cop-map)
+(define-key 'ecasound-cop-map "a" 'eci-cop-add)
+(define-key 'ecasound-cop-map "i" 'eci-cop-select)
+(define-key 'ecasound-cop-map "l" 'eci-cop-list)
+(define-key 'ecasound-cop-map "s" 'eci-cop-status)
+(define-key 'ecasound-cop-map "x" 'eci-cop-remove)
+(defvar ecasound-audioin-map nil
+ "Keymap used for audio input objects.")
+(define-prefix-command 'ecasound-audioin-map)
+(define-key 'ecasound-audioin-map "a" 'eci-ai-add)
+(define-key 'ecasound-audioin-map "f" 'eci-ai-forward)
+(define-key 'ecasound-audioin-map "r" 'eci-ai-rewind)
+(define-key 'ecasound-audioin-map "x" 'eci-ai-remove)
+(defvar ecasound-audioout-map nil
+ "Keymap used for audio output objects.")
+(define-prefix-command 'ecasound-audioout-map)
+(define-key 'ecasound-audioout-map "a" 'eci-ao-add)
+(define-key 'ecasound-audioout-map "d" 'eci-ao-add-default)
+(define-key 'ecasound-audioout-map "f" 'eci-ao-forward)
+(define-key 'ecasound-audioout-map "r" 'eci-ao-rewind)
+(define-key 'ecasound-audioout-map "x" 'eci-ao-remove)
+(defvar ecasound-cs-map nil
+ "Keymap used for Chainsetup operations.")
+(define-prefix-command 'ecasound-cs-map)
+(define-key 'ecasound-cs-map "a" 'eci-cs-add)
+(define-key 'ecasound-cs-map "c" 'eci-cs-connect)
+(define-key 'ecasound-cs-map "d" 'eci-cs-disconnect)
+(define-key 'ecasound-cs-map "f" 'eci-cs-forward)
+(define-key 'ecasound-cs-map "r" 'eci-cs-rewind)
+(define-key 'ecasound-cs-map "t" 'eci-cs-toogle-loop)
+
+(defvar ecasound-iam-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map comint-mode-map)
+ (define-key map "\t" 'pcomplete)
+ (define-key map (kbd "M-c") 'ecasound-chain-map)
+ (define-key map (kbd "M-i") 'ecasound-audioin-map)
+ (define-key map (kbd "M-o") 'ecasound-audioout-map)
+ (define-key map (kbd "M-\"") 'eci-command)
+ map))
+
+(easy-menu-define
+ ecasound-iam-cs-menu ecasound-iam-mode-map
+ "Chainsetup menu."
+ (list "Chainsetup"
+ ["Add..." eci-cs-add t]
+ ["Load..." eci-cs-load t]
+ ["Save" eci-cs-save t]
+ ["Save As..." eci-cs-save-as t]
+ ["List" eci-cs-list t]
+ ["Select" eci-cs-select t]
+ ["Select via index" eci-cs-index-select t]
+ "-"
+ ["Selected" eci-cs-selected t]
+ ["Valid?" eci-cs-is-valid t]
+ ["Connect" eci-cs-connect (eci-cs-is-valid-p)]
+ ["Disconnect" eci-cs-disconnect t]
+ ["Get position" eci-cs-get-position t]
+ ["Get length" eci-cs-get-length t]
+ ["Get length in samples" eci-cs-get-length-samples t]
+ ["Forward..." eci-cs-forward t]
+ ["Rewind..." eci-cs-rewind t]
+ ))
+(easy-menu-add ecasound-iam-cs-menu ecasound-iam-mode-map)
+(easy-menu-define
+ ecasound-iam-c-menu ecasound-iam-mode-map
+ "Chain menu."
+ (list "Chain"
+ ["Add..." eci-c-add t]
+ ["Select..." eci-c-select t]
+ ["Select All" eci-c-select-all t]
+ ["Deselect..." eci-c-deselect (> (length (eci-c-selected)) 0)]
+ ["Selected" eci-c-selected t]
+ ["Mute" eci-c-mute t]
+ ["Clear" eci-c-clear t]
+ ))
+(easy-menu-add ecasound-iam-c-menu ecasound-iam-mode-map)
+(easy-menu-define
+ ecasound-iam-cop-menu ecasound-iam-mode-map
+ "Chain Operator menu."
+ (list "ChainOp"
+ ["Add..." eci-cop-add (> (length (eci-c-selected)) 0)]
+ ["Select..." eci-cop-select t]
+ ["Edit..." ecasound-cop-edit t]
+ "-"
+ ["Select parameter..." eci-copp-select t]
+ ["Get parameter value" eci-copp-get t]
+ ["Set parameter value..." eci-copp-set t]
+ ))
+(easy-menu-add ecasound-iam-c-menu ecasound-iam-mode-map)
+(easy-menu-define
+ ecasound-iam-ai-menu ecasound-iam-mode-map
+ "Audio Input Object menu."
+ (list "AudioIn"
+ ["Add..." eci-ai-add (> (length (eci-c-selected)) 0)]
+ ["List" eci-ai-list t]
+ ["Select..." eci-ai-select t]
+ ["Index select..." eci-ai-index-select t]
+ "-"
+ ["Attach" eci-ai-attach t]
+ ["Remove" eci-ai-remove t]
+ ["Forward..." eci-ai-forward t]
+ ["Rewind..." eci-ai-rewind t]
+ ))
+(easy-menu-add ecasound-iam-ai-menu ecasound-iam-mode-map)
+(easy-menu-define
+ ecasound-iam-ao-menu ecasound-iam-mode-map
+ "Audio Output Object menu."
+ (list "AudioOut"
+ ["Add..." eci-ao-add (> (length (eci-c-selected)) 0)]
+ ["Add default" eci-ao-add-default (> (length (eci-c-selected)) 0)]
+ ["List" eci-ao-list t]
+ ["Select..." eci-ao-select t]
+ ["Index select..." eci-ao-index-select t]
+ "-"
+ ["Attach" eci-ao-attach t]
+ ["Remove" eci-ao-remove t]
+ ["Forward..." eci-ao-forward t]
+ ["Rewind..." eci-ao-rewind t]
+ ))
+(easy-menu-add ecasound-iam-ao-menu ecasound-iam-mode-map)
+
+(easy-menu-define
+ ecasound-menu global-map
+ "Ecasound menu."
+ (list "Ecasound"
+ ["Get session" ecasound t]
+ "-"
+ ["Normalize..." ecasound-normalize t]
+ ["Signalview..." ecasound-signalview t]
+ "-"
+ ["Customize startup..." ecasound-customize-startup t]
+ ))
+(easy-menu-add ecasound-menu global-map)
+
+(make-variable-buffer-local
+ (defvar ecasound-mode-string nil))
+
+(define-derived-mode ecasound-iam-mode comint-mode "EIAM"
+ "Special mode for ecasound processes in interactive mode."
+ (set (make-local-variable 'comint-prompt-regexp)
+ (set (make-local-variable 'paragraph-start)
+ ecasound-prompt-regexp))
+ (add-hook 'comint-output-filter-functions 'ecasound-output-filter nil t)
+ (add-hook 'comint-input-filter-functions 'eci-input-filter nil t)
+ (ecasound-iam-setup-pcomplete)
+ (setq mode-line-format ecasound-mode-line-format))
+
+(defun ecasound-mode-line-cop-list (handle)
+ (let ((list (eci-cop-list handle))
+ (sel (1- (eci-cop-selected handle)))
+ (str ""))
+ (dotimes (i (length list) str)
+ (setq str (format "%s%s%s%s"
+ str
+ (if (= i sel) "*" "")
+ (nth i list)
+ (if (= i (length list)) "" ","))))))
+
+(defsubst ecasound-daemon-p ()
+ "Predicate used to determine if there is an active daemon channel."
+ (and (buffer-live-p ecasound-daemon)
+ (eq (process-status ecasound-daemon) 'open)))
+
+(defun ecasound-kill-timer ()
+ "Cancels the background timer.
+Use this if you want to stop background information fetching."
+ (interactive)
+ (when ecasound-daemon-timer
+ (cancel-timer ecasound-daemon-timer)))
+
+(defun ecasound-kill-daemon ()
+ "Terminate the daemon channel."
+ (interactive)
+ (ecasound-kill-timer)
+ (when (ecasound-daemon-p)
+ (kill-buffer ecasound-daemon)))
+
+(defun ecasound-update-mode-line (buffer)
+ (when (and (buffer-live-p buffer)
+ (get-buffer-window buffer 'visible))
+ (unless ecasound-sending-command
+ (with-current-buffer buffer
+ (when (ecasound-daemon-p)
+ (eci-engine-status ecasound-daemon)
+ (setq ecasound-mode-string
+ (list
+ " [" (ecasound-position-to-string
+ (eci-cs-get-position ecasound-daemon))
+ "/" (ecasound-position-to-string
+ (eci-cs-get-length ecasound-daemon))
+ "]"
+ )
+ header-line-format
+ (list
+ (eci-cs-selected ecasound-daemon)
+ " [" (if (eci-cs-is-valid-p ecasound-daemon)
+ "valid"
+ "N/A") "]: ("
+ (mapconcat 'identity (eci-c-list ecasound-daemon) ",")
+ ") "
+ (mapconcat 'identity
+ (eci-c-selected ecasound-daemon) ","))))))))
+
+(defun ecasound-setup-timer ()
+ (when (and ecasound-timer-flag (ecasound-daemon-p))
+ (setq ecasound-daemon-timer
+ (run-with-timer
+ 0 ecasound-timer-interval
+ 'ecasound-update-mode-line
+ (current-buffer)))))
+
+(make-variable-buffer-local
+ (defvar eci-int-output-mode-wellformed-flag nil
+ "Indicates if int-output-mode-wellformed was successfully initialized."))
+
+(make-variable-buffer-local
+ (defvar eci-engine-status nil
+ "If non-nil, a string describing the engine-status."))
+
+(make-variable-buffer-local
+ (defvar eci-cs-selected nil
+ "If non-nil, a string describing the selected chain setup."))
+
+;;;###autoload
+(defun ecasound (&optional buffer)
+ "Run an inferior ecasound, with I/O through BUFFER.
+BUFFER defaults to `*ecasound*'.
+Interactively, a prefix arg means to prompt for BUFFER.
+If BUFFER exists but ecasound process is not running, make new ecasound
+process using `ecasound-arguments'.
+If BUFFER exists and ecasound process is running, just switch to BUFFER.
+The buffer is put in ecasound mode, giving commands for sending input and
+completing IAM commands. See `ecasound-iam-mode'.
+
+\(Type \\[describe-mode] in the ecasound buffer for a list of commands.)"
+ (interactive
+ (list
+ (and current-prefix-arg
+ (read-buffer "Ecasound buffer: " "*ecasound*"))))
+ (when (null buffer)
+ (setq buffer "*ecasound*"))
+ (if (not (comint-check-proc buffer))
+ (pop-to-buffer
+ (save-excursion
+ (set-buffer
+ (apply 'make-comint
+ "ecasound"
+ ecasound-program
+ nil
+ ecasound-arguments))
+ (ecasound-iam-mode)
+ ;; Flush process output
+ (while (accept-process-output
+ (get-buffer-process (current-buffer))
+ 1))
+ (if (consp ecasound-program)
+ ;; If we're connecting via tcp/ip, we're most probably connecting
+ ;; to a daemon-mode ecasound session.
+ (setq comint-input-sender 'ecasound-network-send
+ eci-int-output-mode-wellformed-flag t)
+ (let ((eci-hide-output nil))
+ (if (not (eq (eci-command "int-output-mode-wellformed") t))
+ (message "Failed to initialize properly"))))
+ (when (member "--daemon" ecasound-arguments)
+ (ecasound-setup-daemon))
+ (current-buffer)))
+ (pop-to-buffer buffer)))
+
+(defun ecasound-setup-daemon ()
+ (let ((cb (current-buffer)))
+ (if (ecasound-daemon-p)
+ (error "Ecasound Daemon %S already initialized" ecasound-daemon)
+ (setq ecasound-daemon
+ (save-excursion
+ (set-buffer
+ (make-comint
+ "ecasound-daemon"
+ (cons "localhost" (ecasound-daemon-port))))
+ (ecasound-iam-mode)
+ (setq comint-input-sender 'ecasound-network-send
+ eci-int-output-mode-wellformed-flag t
+ ecasound-parent cb)
+ (set (make-variable-buffer-local 'comint-highlight-prompt) nil)
+ (setq comint-output-filter-functions '(ecasound-output-filter))
+ (current-buffer)))
+ (if (ecasound-daemon-p)
+ (progn (add-hook 'kill-buffer 'ecasound-kill-daemon nil t)
+ (ecasound-setup-timer))
+ (message "Ecasound daemon initialisation failed")))))
+
+(defun ecasound-delete-last-in-and-output ()
+ "Delete the region of text generated by the last in and output.
+This is usually used to hide ECI requests from the user."
+ (delete-region
+ (save-excursion (goto-char comint-last-input-end) (forward-line -1)
+ (unless (looking-at ecasound-prompt-regexp)
+ (error "Assumed ecasound-prompt"))
+ (point))
+ comint-last-output-start))
+
+(make-variable-buffer-local
+ (defvar eci-last-command nil
+ "Last command sent to the ecasound process."))
+
+(make-variable-buffer-local
+ (defvar ecasound-last-parse-start nil
+ "Where to start parsing if output is received.
+This marker is advanced everytime a successful parse happens."))
+
+(defun eci-input-filter (string)
+ "Track commands sent to ecasound.
+Argument STRING is the input sent."
+ (when (string-match "^[[:space:]]*\\([a-zA-Z-]+\\)[\n\t ]+" string)
+ (setq eci-last-command (match-string-no-properties 1 string)
+ ;; This is a precaution, but it makes sense
+ ecasound-last-parse-start (point))
+ (when (or (string= eci-last-command "quit")
+ (string= eci-last-command "q"))
+ ;; Prevents complete hangup, still a bit mysterius
+ (ecasound-kill-daemon))))
+
+(defun ecasound-network-send (proc string)
+ "Function for sending to PROC input STRING via network."
+ (comint-send-string proc string)
+ (comint-send-string proc "\r\n"))
+
+(defcustom ecasound-last-command-alist
+ '(("int-output-mode-wellformed" .
+ (setq eci-int-output-mode-wellformed-flag t))
+ ("int-cmd-list" .
+ (setq ecasound-iam-commands value))
+ ("map-cop-list" .
+ (setq eci-map-cop-list (eci-process-map-list value)))
+ ("map-ladspa-list" .
+ (setq eci-map-ladspa-list (eci-process-map-list value)))
+ ("map-ctrl-list" .
+ (setq eci-map-ctrl-list (eci-process-map-list value)))
+ ("map-preset-list" .
+ (setq eci-map-preset-list (eci-process-map-list value)))
+ ("cop-status" .
+ (eci-process-cop-status value))
+ ("engine-status" .
+ (setq eci-engine-status value))
+ ("cs-selected" .
+ (setq eci-cs-selected value)))
+ "*Alist of command/expression pairs.
+If `ecasound-last-command' is one of the alist keys, the value of that entry
+will be evaluated with the variable VALUE bound to the commands
+result value."
+ :group 'ecasound
+ :type '(alist :key-type (string :tag "Command")
+ :value-type (sexp :tag "Lisp Expression")))
+
+(defcustom ecasound-type-alist
+ '(("-" . t)
+ ("i" . (string-to-number value))
+ ("li" . (string-to-number value))
+ ("f" . (string-to-number value))
+ ("s" . value)
+ ("S" . (split-string value ","))
+ ("e" . (progn (run-hook-with-args 'ecasound-error-hook value) nil)))
+ "*Alist defining ECI type conversion.
+Each key is a type, and the values are Lisp expressions. During evaluation
+the variables TYPE and VALUE are bound respectively."
+ :group 'ecasound
+ :type '(alist :key-type (string :tag "Type")
+ :value-type (sexp :tag "Lisp Expression")))
+
+(defun ecasound-process-result (type value)
+ "Process ecasound result.
+This function is called if `ecasound-output-filter' detected an ECI reply.
+Argument TYPE the ECI type as a string and argument VALUE is the value as
+a string.
+This function uses `ecasound-type-alist' and `ecasound-last-command-alist'
+to decide how to transform its arguments."
+ (let ((tcode (member* type ecasound-type-alist :test 'string= :key 'car))
+ (lcode (member* eci-last-command ecasound-last-command-alist
+ :test 'string= :key 'car)))
+ (if tcode
+ (setq value (eval (cdar tcode)))
+ (error "Return type '%s' not defined in `ecasound-type-alist'" type))
+ (setq eci-return-value value
+ eci-return-type type
+ eci-result
+ (if lcode
+ (eval (cdar lcode))
+ value))))
+
+(make-variable-buffer-local
+ (defvar eci-return-type nil
+ "The return type of the last received return value as a string."))
+
+(make-variable-buffer-local
+ (defvar eci-return-value nil
+ "The last received return value as a string."))
+
+(make-variable-buffer-local
+ (defvar eci-result nil
+ "The last received return value as a Lisp Object."))
+
+(defun ecasound-output-filter (string)
+ "Parse ecasound process output.
+This function should be used on `comint-output-filter-functions' hook.
+STRING is the string originally received and inserted into the buffer."
+ (let ((start (or ecasound-last-parse-start (point-min)))
+ (end (process-mark (get-buffer-process (current-buffer)))))
+ (when (< start end)
+ (save-excursion
+ (let (type value (end (copy-marker end)))
+ (goto-char start)
+ (while (re-search-forward
+ "\\([0-9]\\{1,3\\}\\) \\([0-9]\\{1,5\\}\\)\\( \\(.*\\)\\)?\n"
+ end t)
+ (let* ((loglevel (string-to-number (match-string 1)))
+ (msgsize (string-to-number (match-string 2)))
+ (return-type (match-string-no-properties 4))
+ (msg (buffer-substring-no-properties
+ (point)
+ (progn
+ (if (> (- (point-max) (point)) msgsize)
+ (progn
+ (forward-char msgsize)
+ (if (not (save-match-data
+ (looking-at
+ "\\(\n\n\\|\r\n\r\n\\)")))
+ (error "Malformed ECI message")
+ (point)))
+ (point-max))))))
+ (when (= msgsize (length msg))
+ (if (and (= loglevel 256)
+ (string= return-type "e"))
+ (add-text-properties
+ (match-end 0) (point)
+ (list 'face 'ecasound-error-face)))
+ (when ecasound-parse-cleanup-buffer
+ (delete-region (match-beginning 0) (if (= msgsize 0)
+ (point)
+ (match-end 0)))
+ (delete-char 1))
+ (setq ecasound-last-parse-start (point))
+ (if (not (= loglevel 256))
+ (run-hook-with-args 'ecasound-message-hook loglevel msg)
+ (setq value msg
+ type (if (string-match "\\(.*\\)\r" return-type)
+ (match-string 1 return-type)
+ return-type))))))
+ (when type
+ (ecasound-process-result type value)))))))
+
+(defmacro defeci (name &optional args doc &rest body)
+ "Defines an ECI command.
+Argument NAME is used for the function name with eci- as prefix.
+Optional argument ARGS specifies the arguments this ECI command has.
+Optional argument DOC is the docstring used for the defined function.
+BODY can start with keyword arguments to indicated certain special cases. The
+following keyword arguments are implemented:
+ :cache VARNAME The command should try to find a cached version of the result
+ in VARNAME.
+ :pcomplete VALUE The command can provide programmable completion. Possible
+ values are the symbol DOC, which indicates that pcomplete
+ should echo the docstring of the eci command. Alternatively
+ you can provide a sexp which is used for the pcomplete
+ definition."
+ (let ((sym (intern (format "eci-%S" name)))
+ (pcmpl-sym (intern (format "pcomplete/ecasound-iam-mode/%S" name)))
+ (cmd `(eci-command
+ ,(if args
+ `(format ,(format "%S %s"
+ name (mapconcat #'caddr args ","))
+ ,@(mapcar
+ (lambda (arg)
+ `(if (or (stringp ,(car arg))
+ (numberp ,(car arg)))
+ ,(car arg)
+ (mapconcat #'identity ,(car arg) ",")))
+ args))
+ (format "%S" name))
+ buffer-or-process))
+ cache cache-doc pcmpl aliases)
+ (while (keywordp (car body))
+ (case (pop body)
+ (:cache (setq cache (pop body)))
+ (:cache-doc (setq cache-doc (pop body)))
+ (:pcomplete (setq pcmpl (pop body)))
+ (:alias (setq aliases (pop body)))
+ (t (pop body))))
+ (when (and (not (eq aliases nil))
+ (not (consp aliases)))
+ (setq aliases (list aliases)))
+ `(progn
+ ,(if cache
+ `(make-variable-buffer-local
+ (defvar ,cache ,@(if cache-doc (list nil cache-doc) (list nil)))))
+ (defun ,sym
+ ,(if args (append (mapcar #'car args) `(&optional buffer-or-process))
+ `(&optional buffer-or-process))
+ ,(if doc doc "")
+ ,(if args `(interactive
+ ,(if (let (done)
+ (mapcar (lambda (x) (when x (setq done t)))
+ (mapcar #'stringp (mapcar #'cadr args)))
+ done)
+ (mapconcat #'identity (mapcar #'cadr args) "\n")
+ `(list ,@(mapcar #'cadr args))))
+ `(interactive))
+ ,@(cond
+ ((and cache (eq body nil))
+ `((let ((cached (with-current-buffer
+ (ecasound-find-buffer buffer-or-process)
+ ,(or cache (and (ecasound-daemon-p)
+ (with-current-buffer
+ ecasound-daemon
+ ,cache))))))
+ (if cached
+ cached
+ ,cmd))))
+ ((eq body nil)
+ `(,cmd))
+ (t body)))
+ ,@(mapcar
+ (lambda (alias) `(defalias ',(intern (format "eci-%S" alias))
+ ',sym)) aliases)
+ ,(when pcmpl
+ `(progn
+ ,(if (and (eq pcmpl 'doc) (stringp doc) (not (string= doc "")))
+ `(defun ,pcmpl-sym ()
+ (message ,doc)
+ (throw 'pcompleted t))
+ `(defun ,pcmpl-sym ()
+ ,pcmpl))
+ ,@(mapcar
+ (lambda (alias)
+ `(defalias ',(intern (format "pcomplete/ecasound-iam-mode/%S" alias))
+ ',pcmpl-sym))
+ aliases))))))
+
+(defeci map-cop-list ()
+ "Returns a list of registered chain operators."
+ :cache eci-map-cop-list
+ :cache-doc "If non-nil, contains the chainop object map.
+It has the form
+ ((NAME PREFIX DESCR ((ARGNAME DESCR DEFAULT LOW HIGH TYPE) ...)) ...)
+
+Use `eci-map-cop-list' to fill this variable with data.")
+
+(defeci map-ctrl-list ()
+ "Returns a list of registered controllers."
+ :cache eci-map-ctrl-list
+ :cache-doc "If non-nil, contains the chainop controller object map.
+It has the form
+ ((NAME PREFIX DESCR ((ARGNAME DESCR DEFAULT LOW HIGH TYPE) ...)) ...)
+
+Use `eci-map-ctrl-list' to fill this list with data.")
+
+(defeci map-ladspa-list ()
+ "Returns a list of registered LADSPA plugins."
+ :cache eci-map-ladspa-list
+ :cache-doc "If non-nil, contains the LADSPA object map.
+It has the form
+ ((NAME PREFIX DESCR ((ARGNAME DESCR DEFAULT LOW HIGH TYPE) ...)) ...)
+
+Use `eci-map-ladspa-list' to fill this list with data.")
+
+(defeci map-preset-list ()
+ "Returns a list of registered effect presets."
+ :cache eci-map-preset-list
+ :cache-doc "If non-nil, contains the preset object map.
+It has the form
+ ((NAME PREFIX DESCR ((ARGNAME DESCR DEFAULT LOW HIGH TYPE) ...)) ...)
+
+Use `eci-map-preset-list' to fill this list with data.")
+
+;;; Ecasound-iam-mode pcomplete functions
+
+(defun ecasound-iam-setup-pcomplete ()
+ "Setup buffer-local functions for pcomplete in `ecasound-iam-mode'."
+ (set (make-local-variable 'pcomplete-command-completion-function)
+ (lambda ()
+ (pcomplete-here (if ecasound-iam-commands
+ ecasound-iam-commands
+ (eci-hide-output eci-int-cmd-list)))))
+ (set (make-local-variable 'pcomplete-command-name-function)
+ (lambda ()
+ (pcomplete-arg 'first)))
+ (set (make-local-variable 'pcomplete-parse-arguments-function)
+ 'ecasound-iam-pcomplete-parse-arguments))
+
+(defun ecasound-iam-pcomplete-parse-arguments ()
+ "Parse arguments in the current region.
+\" :,\" are considered for splitting."
+ (let ((begin (save-excursion (comint-bol nil) (point)))
+ (end (point))
+ begins args)
+ (save-excursion
+ (goto-char begin)
+ (while (< (point) end)
+ (skip-chars-forward " \t\n,:")
+ (setq begins (cons (point) begins))
+ (let ((skip t))
+ (while skip
+ (skip-chars-forward "^ \t\n,:")
+ (if (eq (char-before) ?\\)
+ (skip-chars-forward " \t\n,:")
+ (setq skip nil))))
+ (setq args (cons (buffer-substring-no-properties
+ (car begins) (point))
+ args)))
+ (cons (reverse args) (reverse begins)))))
+
+(defun ecasound-input-file-or-device ()
+ "Return a list of possible completions for input device name."
+ (append (delq
+ nil
+ (mapcar
+ (lambda (elt)
+ (when (string-match
+ (concat "^" (regexp-quote pcomplete-stub)) elt)
+ elt))
+ (list "alsa" "alsahw" "alsalb" "alsaplugin"
+ "arts" "loop" "null" "stdin")))
+ (pcomplete-entries)))
+
+;;;; IAM commands
+
+(defun eci-map-find-args (arg map)
+ "Return the argument specification for ARG in MAP."
+ (let (result)
+ (while map
+ (if (string= (nth 1 (car map)) arg)
+ (setq result (nthcdr 3 (car map))
+ map nil)
+ (setq map (cdr map))))
+ result))
+
+(defun ecasound-echo-arg (arg)
+ "Display a chain operator parameter description from a eci-map-*-list
+variable."
+ (if arg
+ (let ((type (nth 5 arg)))
+ (message "%s%s%s, default %S%s%s"
+ (car arg)
+ (if type (format " (%S)" type) "")
+ (if (and (not (string= (nth 1 arg) ""))
+ (not (string= (car arg) (nth 1 arg))))
+ (format " (%s)" (nth 1 arg))
+ "")
+ (nth 2 arg)
+ (if (nth 4 arg) (format " min %S" (nth 4 arg)) "")
+ (if (nth 3 arg) (format " max %S" (nth 3 arg)) "")))
+ (message "No help available")))
+
+\f
+;;; ECI --- The Ecasound Control Interface
+
+(defgroup eci nil
+ "Ecasound Control Interface."
+ :group 'ecasound)
+
+(defcustom eci-program (or (getenv "ECASOUND") "ecasound")
+ "*Program to invoke when doing `eci-init'."
+ :group 'eci
+ :type '(choice string (cons string string)))
+
+(defcustom eci-arguments '("-c" "-D" "-d:256")
+ "*Arguments used by `eci-init'."
+ :group 'eci
+ :type 'ecasound-args)
+
+(defvar eci-hide-output nil
+ "If non-nil, `eci-command' will remove the output generated.")
+
+(defmacro eci-hide-output (&rest eci-call)
+ "Hide the output of this ECI-call.
+If a daemon-channel is active, use that, otherwise set `eci-hide-output' to t.
+Argument ECI-CALL is a symbol followed by its aruments if any."
+ `(if (ecasound-daemon-p)
+ ,(append eci-call (list 'ecasound-daemon))
+ (let ((eci-hide-output t))
+ ,eci-call)))
+
+(defun eci-init ()
+ "Initialize a programmatic ECI session.
+Every call to this function results in a new sub-process being created
+according to `eci-program' and `eci-arguments'. Returns the newly
+created buffer.
+The caller is responsible for terminating the subprocess at some point."
+ (save-excursion
+ (set-buffer
+ (apply 'make-comint
+ "eci-ecasound"
+ eci-program
+ nil
+ eci-arguments))
+ (ecasound-iam-mode)
+ (while (accept-process-output (get-buffer-process (current-buffer)) 1))
+ (if (eci-command "int-output-mode-wellformed")
+ (current-buffer))))
+
+(defun eci-interactive-startup ()
+ "Used to interactively startup a ECI session using `eci-init'.
+This will mostly be used for testing sessions and is equivalent
+to `ecasound'."
+ (interactive)
+ (switch-to-buffer (eci-init)))
+
+(defun ecasound-find-buffer (buffer-or-process)
+ (cond
+ ((bufferp buffer-or-process)
+ buffer-or-process)
+ ((processp buffer-or-process)
+ (process-buffer buffer-or-process))
+ ((and (eq major-mode 'ecasound-iam-mode)
+ (comint-check-proc (current-buffer)))
+ (current-buffer))
+ (t (error "Could not determine suitable ecasound buffer"))))
+
+(defun ecasound-find-parent (buffer-or-process)
+ (with-current-buffer (ecasound-find-buffer buffer-or-process)
+ (if ecasound-parent
+ ecasound-parent
+ (current-buffer))))
+
+(defun eci-command (command &optional buffer-or-process)
+ "Send a ECI command to a ECI host process.
+COMMAND is the string to be sent, without a newline character.
+If BUFFER-OR-PROCESS is nil, first look for a ecasound process in the current
+buffer, then for a ecasound buffer with the name *ecasound*,
+otherwise use the buffer or process supplied.
+Return the string we received in reply to the command except
+`eci-int-output-mode-wellformed-flag' is set, which means we can parse the
+output via `eci-parse' and return a meaningful value."
+ (interactive "sECI Command: ")
+ (let* ((buf (ecasound-find-buffer buffer-or-process))
+ (proc (get-buffer-process buf))
+ (ecasound-sending-command t))
+ (with-current-buffer buf
+ (let ((moving (= (point) (point-max))))
+ (setq eci-result 'waiting)
+ (goto-char (process-mark proc))
+ (insert command)
+ (let (comint-eol-on-send)
+ (comint-send-input))
+ (let ((here (point)) result)
+ (while (eq eci-result 'waiting)
+ (accept-process-output proc 0 30))
+ (setq result
+ (if eci-int-output-mode-wellformed-flag
+ eci-result
+ ;; Backward compatibility. Just return the string
+ (buffer-substring-no-properties here (save-excursion
+ ; Strange hack to avoid fields
+ (forward-char -1)
+ (beginning-of-line)
+ (if (not (= here (point)))
+ (forward-char -1))
+ (point)))))
+ (if moving (goto-char (point-max)))
+ (when (and eci-hide-output result)
+ (ecasound-delete-last-in-and-output))
+ result)))))
+
+(defsubst eci-error-p ()
+ "Predicate which can be used to check if the last command produced an error."
+ (string= eci-return-type "e"))
+
+;;; ECI commands implemented as lisp functions
+
+(defeci int-cmd-list ()
+ ""
+ :cache ecasound-iam-commands
+ :cache-doc "Available Ecasound IAM commands.")
+
+(defeci run)
+
+(defeci start)
+
+(defeci cs-add ((chainsetup "sChainsetup to add: " "%s"))
+ "Adds a new chainsetup with name `name`."
+ :pcomplete doc)
+
+(defeci cs-connect ()
+ "Connect currently selected chainsetup to engine."
+ :pcomplete doc)
+
+(defeci cs-connected ()
+ "Returns the name of currently connected chainsetup."
+ :pcomplete doc)
+
+(defeci cs-disconnect ()
+ "Disconnect currently connected chainsetup."
+ :pcomplete doc)
+
+(defeci cs-forward
+ ((seconds
+ (if current-prefix-arg
+ (prefix-numeric-value current-prefix-arg)
+ (read-minibuffer (format "Time in seconds to forward %s: "
+ (eci-hide-output eci-cs-selected)))) "%f")))
+
+(defeci cs-get-length ()
+ ""
+ :alias get-length)
+
+(defeci cs-get-length-samples ()
+ ""
+ :alias get-length-samples)
+
+(defeci cs-get-position ()
+ ""
+ :alias (cs-getpos getpos get-position))
+
+(defeci cs-index-select ((index "nChainsetup index: " "%d"))
+ ""
+ :alias cs-iselect)
+
+(defeci cs-is-valid ()
+ "Whether currently selected chainsetup is valid (=can be connected)?"
+ :pcomplete doc
+ (let ((val (eci-command "cs-is-valid" buffer-or-process)))
+ (if (interactive-p)
+ (message (format "Chainsetup is%s valid" (if (= val 0) "" " not"))))
+ val))
+
+(defun eci-cs-is-valid-p (&optional buffer-or-process)
+ "Predicate function used to determine chain setup validity."
+ (case (eci-cs-is-valid buffer-or-process)
+ (1 t)
+ (0 nil)
+ (otherwise (error "Unexcpected return value from cs-is-valid"))))
+
+(defeci cs-list ()
+ "Returns a list of all chainsetups."
+ :pcomplete doc
+ (let ((val (eci-command "cs-list" buffer-or-process)))
+ (if (interactive-p)
+ (message (concat "Available chainsetups: "
+ (mapconcat #'identity val ", "))))
+ val))
+
+(defeci cs-load ((filename "fChainsetup filename: " "%s"))
+ "Adds a new chainsetup by loading it from file FILENAME.
+FILENAME is then the selected chainsetup."
+ :pcomplete (pcomplete-here (pcomplete-entries)))
+
+(defeci cs-remove ()
+ "Removes currently selected chainsetup."
+ :pcomplete doc)
+
+(defeci cs-rewind
+ ((seconds
+ (if current-prefix-arg
+ (prefix-numeric-value current-prefix-arg)
+ (read-minibuffer "Time in seconds to rewind chainsetup: ")) "%f"))
+ "Rewinds the current chainsetup position by `time-in-seconds` seconds."
+ :pcomplete doc
+ :alias (rewind rw))
+
+(defeci cs-save)
+
+(defeci cs-save-as ((filename "FChainsetup filename: " "%s"))
+ "Saves currently selected chainsetup to file FILENAME."
+ :pcomplete (pcomplete-here (pcomplete-entries)))
+
+(defeci cs-selected ()
+ "Returns the name of currently selected chainsetup."
+ :pcomplete doc
+ (let ((val (with-current-buffer (ecasound-find-parent buffer-or-process)
+ (setq eci-cs-selected (eci-command "cs-selected"
+ buffer-or-process)))))
+ (if (interactive-p)
+ (message (format "Selected chainsetup: %s" val)))
+ val))
+
+(defeci cs-status)
+
+(defeci c-add ((chains "sChain(s) to add: " "%s"))
+ "Adds a set of chains. Added chains are automatically selected.
+If argument CHAINS is a list, its elements are concatenated with ','.")
+
+(defeci c-clear ()
+ "Clear selected chains by removing all chain operators and controllers.
+Doesn't change how chains are connected to inputs and outputs."
+ :pcomplete doc)
+
+(defun ecasound-read-list (prompt list)
+ "Interactively prompt for a number of inputs until empty string.
+PROMPT is used as prompt and LIST is a list of choices to choose from."
+ (let ((avail list)
+ result current)
+ (while
+ (and avail
+ (not
+ (string=
+ (setq current (completing-read prompt (mapcar #'list avail)))
+ "")))
+ (setq result (cons current result)
+ avail (delete current avail)))
+ (nreverse result)))
+
+(defeci c-deselect
+ ((chains (ecasound-read-list "Chain to deselect: " (eci-c-selected)) "%s"))
+ "Deselects chains."
+ :pcomplete (while (pcomplete-here (eci-c-selected))))
+
+(defeci c-list ()
+ "Returns a list of all chains.")
+
+(defeci c-mute ()
+ "Toggle chain muting. When chain is muted, all data that goes
+through is muted."
+ :pcomplete doc)
+
+(defeci c-select ((chains (ecasound-read-list "Chain: " (eci-c-list)) "%s"))
+ "Selects chains. Other chains are automatically deselected."
+ :pcomplete doc)
+
+(defeci c-selected ()
+ ""
+ (let ((val (eci-command "c-selected" buffer-or-process)))
+ (if (interactive-p)
+ (if (null val)
+ (message "No selected chains")
+ (message (concat "Selected chains: "
+ (mapconcat #'identity val ", ")))))
+ val))
+
+(defeci c-select-all ()
+ "Selects all chains."
+ :pcomplete doc)
+
+(defeci cs-select
+ ((chainsetup
+ (completing-read "Chainsetup: " (mapcar #'list (eci-cs-list)))
+ "%s"))
+ ""
+ :pcomplete (pcomplete-here (eci-hide-output eci-cs-list)))
+
+(defeci ai-add
+ ((ifstring
+ (let ((file (read-file-name "Input filename: ")))
+ (if (file-exists-p file)
+ (expand-file-name file)
+ file))
+ "%s"))
+ "Adds a new input object."
+ :pcomplete (pcomplete-here (ecasound-input-file-or-device)))
+
+(defeci ai-attach ()
+ "Attaches the currently selected audio input object to all selected chains."
+ :pcomplete doc)
+
+(defeci ai-forward
+ ((seconds
+ (if current-prefix-arg
+ (prefix-numeric-value current-prefix-arg)
+ (read-minibuffer (format "Time in seconds to forward %s: "
+ (eci-hide-output eci-ai-selected)))) "%f"))
+ "Selected audio input object is forwarded by SECONDS.
+Time should be given as a floating point value (eg. 0.001 is the same as 1ms)."
+ :pcomplete doc
+ :alias ai-fw)
+
+(defeci ai-rewind
+ ((seconds
+ (if current-prefix-arg
+ (prefix-numeric-value current-prefix-arg)
+ (read-minibuffer (format "Time in seconds to rewind %s: "
+ (eci-hide-output eci-ai-selected)))) "%f"))
+ "Selected audio input object is rewinded by SECONDS.
+Time should be given as a floating point value (eg. 0.001 is the same as 1ms)."
+ :pcomplete doc
+ :alias ai-rw)
+
+(defeci ai-index-select ((index "nAudio Input index: " "%d"))
+ "Select some audio input object based on a short index.
+Especially file names can be rather long. This command can be used to avoid
+typing these long names when selecting audio objects.
+INDEX is an integer value, where 1 refers to the first audio input.
+You can use `eci-ai-list' to get a full list of currently available inputs."
+ :pcomplete doc
+ :alias ai-iselect)
+
+(defeci ai-list)
+
+(defeci ai-remove ()
+ "Removes the currently selected audio input object from the chainsetup."
+ :pcomplete doc)
+(defeci ao-remove ()
+ "Removes the currently selected audio output object from the chainsetup."
+ :pcomplete doc)
+
+(defeci ai-select ((name "sAudio Input Object name: " "%s"))
+ "Selects an audio object.
+NAME refers to the string used when creating the object. Note! All input
+object names are required to be unique. Similarly all output names need to be
+unique. However, it's possible that the same object name exists both as an
+input and as an output."
+ :pcomplete (pcomplete-here (eci-hide-output eci-ai-list)))
+
+(defeci ai-selected ()
+ "Returns the name of the currently selected audio input object."
+ :pcomplete doc)
+
+(defeci ao-add ((filename "FOutput filename: " "%s"))
+ ""
+ :pcomplete (pcomplete-here (ecasound-input-file-or-device)))
+
+(defeci ao-add-default)
+
+(defeci ao-attach ()
+ "Attaches the currently selected audio output object to all selected chains."
+ :pcomplete doc)
+
+(defeci ao-forward
+ ((seconds
+ (if current-prefix-arg
+ (prefix-numeric-value current-prefix-arg)
+ (read-minibuffer (format "Time in seconds to forward %s: "
+ (eci-hide-output eci-ao-selected)))) "%f"))
+ "Selected audio output object is forwarded by SECONDS.
+Time should be given as a floating point value (eg. 0.001 is the same as 1ms)."
+ :pcomplete doc
+ :alias ao-fw)
+
+(defeci ao-index-select ((index "nAudio Output index: " "%d"))
+ "Select some audio output object based on a short index.
+Especially file names can be rather long. This command can be used to avoid
+typing these long names when selecting audio objects.
+INDEX is an integer value, where 1 refers to the first audio output.
+You can use `eci-ao-list' to get a full list of currently available outputs."
+ :pcomplete doc
+ :alias ao-iselect)
+
+(defeci ao-list)
+
+(defeci ao-rewind
+ ((seconds
+ (if current-prefix-arg
+ (prefix-numeric-value current-prefix-arg)
+ (read-minibuffer (format "Time in seconds to rewind %s: "
+ (eci-hide-output eci-ai-selected)))) "%f"))
+ "Selected audio output object is rewinded by SECONDS.
+Time should be given as a floating point value (eg. 0.001 is the same as 1ms)."
+ :pcomplete doc
+ :alias ai-rw)
+
+(defeci ao-select ((name "sAudio Output Object name: " "%s"))
+ "Selects an audio object.
+NAME refers to the string used when creating the object. Note! All output
+object names need to be unique. However, it's possible that the same object
+name exists both as an input and as an output."
+ :pcomplete (pcomplete-here (eci-hide-output eci-ao-list)))
+
+(defeci ao-selected ()
+ "Returns the name of the currently selected audio output object."
+ :pcomplete doc)
+
+(defeci engine-status ()
+ "Returns a string describing the engine status
+\(running, stopped, finished, error, not ready)."
+ :pcomplete doc
+ (with-current-buffer (ecasound-find-parent buffer-or-process)
+ (setq eci-engine-status (eci-command "engine-status" buffer-or-process))))
+
+(defmacro ecasound-complete-cop-map (map)
+ (let ((m (intern (format "eci-map-%S-list" map))))
+ `(progn
+ (cond
+ ((= pcomplete-last 2)
+ (pcomplete-next-arg)
+ (pcomplete-here
+ (sort (mapcar (lambda (elt) (nth 1 elt))
+ (eci-hide-output ,m))
+ #'string-lessp)))
+ ((> pcomplete-last 2)
+ (ecasound-echo-arg
+ (nth (- pcomplete-last 3)
+ (eci-map-find-args
+ (pcomplete-arg -1) (eci-hide-output ,m)))))))))
+
+(defeci cop-add
+ ((string
+ (if current-prefix-arg
+ (read-string "Chainop to add: " "-")
+ (let* ((cop
+ (completing-read
+ "Chain operator: "
+ (append (eci-hide-output eci-map-cop-list)
+ (eci-hide-output eci-map-ladspa-list)
+ (eci-hide-output eci-map-preset-list))))
+ (entry (or (assoc cop (eci-map-cop-list))
+ (assoc cop (eci-map-ladspa-list))
+ (assoc cop (eci-map-preset-list))))
+ (arg (nth 1 entry)))
+ (concat
+ (cond
+ ((assoc cop (eci-map-cop-list))
+ (concat "-" arg ":"))
+ ((assoc cop (eci-map-ladspa-list))
+ (concat "-el:" arg ","))
+ ((assoc cop (eci-map-preset-list))
+ (concat "-pn:" arg ",")))
+ (mapconcat #'ecasound-read-copp (nthcdr 3 entry) ","))))
+ "%s"))
+ ""
+ :pcomplete
+ (progn
+ (cond
+ ((= pcomplete-last 1)
+ (pcomplete-here
+ (append
+ '("-el:" "-pn:")
+ (mapcar
+ (lambda (elt)
+ (concat "-" (nth 1 elt) ":"))
+ (eci-hide-output eci-map-cop-list)))))
+ ((string= (pcomplete-arg) "-el")
+ (ecasound-complete-cop-map ladspa))
+ ((string= (pcomplete-arg) "-pn")
+ (ecasound-complete-cop-map preset))
+ ((> pcomplete-last 1)
+ (ecasound-echo-arg
+ (nth (- pcomplete-last 2)
+ (eci-map-find-args
+ (substring (pcomplete-arg) 1)
+ (eci-hide-output eci-map-cop-list))))))
+ (throw 'pcompleted t)))
+
+(defeci cop-list)
+
+(defeci cop-remove)
+
+(defeci cop-select
+ ((index "nChainop to select: " "%d")))
+
+(defeci cop-selected)
+
+;; FIXME: Command seems to be broken in CVS.
+(defeci cop-set ((cop "nChainop id: " "%d")
+ (copp "nParameter id: " "%d")
+ (value "nValue: " "%f"))
+ "Changes the value of a single chain operator parameter.
+Unlike other chain operator commands, this can also be used during processing."
+ :pcomplete doc)
+
+(defeci ctrl-add
+ ((string
+ (if current-prefix-arg
+ (read-string "Controller to add: " "-")
+ (let ((ctrl (assoc
+ (completing-read
+ "Chain operator controller controller: "
+ (eci-hide-output eci-map-ctrl-list))
+ (eci-hide-output eci-map-ctrl-list))))
+ (concat "-" (nth 1 ctrl) ":"
+ (mapconcat #'ecasound-read-copp (nthcdr 3 ctrl) ","))))
+ "%s")))
+
+(defeci ctrl-select
+ ((index "nController to select: " "%d")))
+
+(defeci copp-select
+ ((index "nChainop parameter to select: " "%d")))
+
+(defeci copp-get)
+
+(defeci copp-set
+ ((value "nValue for Chain operator parameter: " "%f")))
+
+;;;; ECI Examples
+
+(defun eci-example ()
+ "Implements the example given in the ECI documentation."
+ (interactive)
+ (save-current-buffer
+ (set-buffer (eci-init))
+ (display-buffer (current-buffer))
+ (eci-cs-add "play_chainsetup")
+ (eci-c-add "1st_chain")
+ (call-interactively #'eci-ai-add)
+ (eci-ao-add "/dev/dsp")
+ (eci-cop-add "-efl:100")
+ (eci-cop-select 1) (eci-copp-select 1)
+ (eci-cs-connect)
+ (eci-command "start")
+ (sit-for 1)
+ (while (and (string= (eci-engine-status) "running")
+ (< (eci-get-position) 15))
+ (eci-copp-set (+ (eci-copp-get) 500))
+ (sit-for 1))
+ (eci-command "stop")
+ (eci-cs-disconnect)
+ (message (concat "Chain operator status: "
+ (eci-command "cop-status")))))
+
+(defun eci-make-temp-file-name (suffix)
+ (concat (make-temp-name
+ (expand-file-name "emacs-eci" temporary-file-directory))
+ suffix))
+
+(defun ecasound-read-from-minibuffer (prompt default)
+ (let ((result (read-from-minibuffer
+ (format "%s (default %S): " prompt default)
+ nil nil nil nil default)))
+ (if (and result (not (string= result "")))
+ result
+ default)))
+
+(defconst ecasound-signalview-clipped-threshold (- 1.0 (/ 1.0 16384)))
+
+(defconst ecasound-signalview-bar-length 55)
+
+(defun ecasound-position-to-string (secs &optional long)
+ "Convert a floating point position value in SECS to a string.
+If optional argument LONG is non-nil, produce a full 00:00.00 string,
+otherwise ignore zeors as well as colons and dots on the left side."
+ (let ((str (format "%02d:%02d.%02d"
+ (/ secs 60)
+ (% (round (floor secs)) 60)
+ (* (- secs (floor secs)) 100))))
+ (if long
+ str
+ (let ((idx 0) (len (1- (length str))))
+ (while (and (< idx len)
+ (let ((ch (aref str idx)))
+ (or (eq ch ?0) (eq ch ?:) (eq ch ?.))))
+ (incf idx))
+ (substring str idx)))))
+
+(defun ecasound-signalview (bufsize format input output)
+ "Interactively view the singal of a audio stream.
+After invokation, this function displays the signal level of the individual
+channels in INPUT based on the information given in FORMAT."
+ (interactive
+ (list
+ (ecasound-read-from-minibuffer "Buffersize" "128")
+ (ecasound-read-from-minibuffer "Format" "s16_le,2,44100,i")
+ (let ((file (read-file-name "Input: ")))
+ (if (file-exists-p file)
+ (expand-file-name file)
+ file))
+ (ecasound-read-from-minibuffer "Output" "null")))
+ (let* (;; THis saves time
+ (ecasound-parse-cleanup-buffer nil)
+ (handle (eci-init))
+ (channels (string-to-number (nth 1 (split-string format ","))))
+ (chinfo (make-vector channels nil)))
+ (dotimes (ch channels) (aset chinfo ch (cons 0 0)))
+ (eci-cs-add "signalview" handle)
+ (eci-c-add "analysis" handle)
+ (eci-cs-set-audio-format format handle)
+ (eci-ai-add input handle)
+ (eci-ao-add output handle)
+ (eci-cop-add "-evp" handle)
+ (eci-cop-add "-ev" handle)
+ (set-buffer (get-buffer-create "*Ecasound-signalview*"))
+ (erase-buffer)
+ (dotimes (ch channels)
+ (insert "---\n"))
+ (setq header-line-format
+ (list (concat "Channel#"
+ (make-string (- ecasound-signalview-bar-length 3) 32)
+ "| max-value clipped")))
+ (set (make-variable-buffer-local 'ecasignalview-position) "unknown")
+ (set (make-variable-buffer-local 'ecasignalview-engine-status) "unknown")
+ (setq mode-line-format
+ (list
+ (list
+ (- ecasound-signalview-bar-length 3)
+ (format "Input: %s, output: %s" input output)
+ 'ecasignalview-engine-status)
+ " | " 'ecasignalview-position))
+ (switch-to-buffer-other-window (current-buffer))
+ (eci-cs-connect handle)
+ (eci-start handle)
+ (sit-for 0.8)
+ (eci-cop-select 1 handle)
+ (while (string= (setq ecasignalview-engine-status
+ (eci-engine-status handle)) "running")
+ (let ((inhibit-quit t) (inhibit-redisplay t))
+ (setq ecasignalview-position
+ (ecasound-position-to-string (eci-cs-get-position handle) t))
+ (delete-region (point-min) (point-max))
+ (dotimes (ch channels)
+ (insert (format "ch%d: " (1+ ch)))
+ (let ((val (progn (eci-copp-select (1+ ch) handle)
+ (eci-copp-get handle)))
+ (bl ecasound-signalview-bar-length))
+ (insert
+ (concat
+ (make-string (round (* val bl)) ?*)
+ (make-string (- bl (round (* val bl))) ? )))
+ (if (> val (car (aref chinfo ch)))
+ (setcar (aref chinfo ch) val))
+ (if (> val ecasound-signalview-clipped-threshold)
+ (incf (cdr (aref chinfo ch))))
+ (insert (format "| %.4f %d\n" (car (aref chinfo ch))
+ (cdr (aref chinfo ch))))))
+ (goto-char (point-min)))
+ (sit-for 0.1)
+ (fit-window-to-buffer))
+ (goto-char (point-max))
+ (let ((pos (point)))
+ (insert
+ (nth 2
+ (nth 2
+ (nthcdr 2
+ (assoc "Volume analysis"
+ (assoc "analysis"
+ (eci-cop-status handle)))))))
+ (goto-char pos))
+ (recenter channels)
+ (fit-window-to-buffer)))
+
+(defun ecasound-normalize (filename)
+ "Normalize a audio file using ECI."
+ (interactive "fFile to normalize: ")
+ (let ((tmpfile (eci-make-temp-file-name ".wav")))
+ (unwind-protect
+ (with-current-buffer (eci-init)
+ (display-buffer (current-buffer)) (sit-for 1)
+ (eci-cs-add "analyze") (eci-c-add "1")
+ (eci-ai-add filename) (eci-ao-add tmpfile)
+ (eci-cop-add "-ev")
+ (message "Analyzing sample data...")
+ (eci-cs-connect) (eci-run)
+ (eci-cop-select 1) (eci-copp-select 2)
+ (let ((gainfactor (eci-copp-get)))
+ (eci-cs-disconnect)
+ (if (<= gainfactor 1)
+ (message "File already normalized!")
+ (eci-cs-add "apply") (eci-c-add "1")
+ (eci-ai-add tmpfile) (eci-ao-add filename)
+ (eci-cop-add "-ea:100")
+ (eci-cop-select 1)
+ (eci-copp-select 1)
+ (eci-copp-set (* gainfactor 100))
+ (eci-cs-connect) (eci-run) (eci-cs-disconnect)
+ (message "Done"))))
+ (if (file-exists-p tmpfile)
+ (delete-file tmpfile)))))
+
+;;; Utility functions for converting strings to data-structures.
+
+(defvar eci-cop-status-header
+ "### Chain operator status (chainsetup '\\([^']+\\)') ###\n")
+
+(defun eci-process-cop-status (string)
+ (with-temp-buffer
+ (insert string) (goto-char (point-min))
+ (when (re-search-forward eci-cop-status-header nil t)
+ (let (result)
+ (while (re-search-forward "Chain \"\\([^\"]+\\)\":\n" nil t)
+ (let ((c (match-string-no-properties 1)) chain)
+ (while (re-search-forward
+ "\t\\([0-9]+\\)\\. \\(.+\\): \\(.*\\)\n?" nil t)
+ (let ((n (string-to-number (match-string 1)))
+ (name (match-string-no-properties 2))
+ (args
+ (mapcar
+ (lambda (elt)
+ (when (string-match
+ "\\[\\([0-9]+\\)\\] \\(.*\\) \\([0-9.-]+\\)$"
+ elt)
+ (list (match-string-no-properties 2 elt)
+ (string-to-number (match-string 1 elt))
+ (string-to-number (match-string 3 elt)))))
+ (split-string
+ (match-string-no-properties 3) ", "))))
+ (if (looking-at "\tStatus info:\n")
+ (setq args
+ (append
+ args
+ (list
+ (list
+ "Status info" nil
+ (buffer-substring
+ (progn (forward-line 1) (point))
+ (or (re-search-forward "\n\n" nil t)
+ (point-max))))))))
+ (setq chain (cons (append (list name n) args) chain))))
+ (setq result (cons (reverse (append chain (list c))) result))))
+ result))))
+
+(defun eci-process-map-list (string)
+ "Parse the output of a map-xxx-list ECI command and return an alist.
+STRING is the string returned by a map-xxx-list command."
+ (mapcar
+ (lambda (elt)
+ (append
+ (list (nth 1 elt) (nth 0 elt) (nth 2 elt))
+ (let (res (count (string-to-number (nth 3 elt))))
+ (setq elt (nthcdr 4 elt))
+ (while (> count 0)
+ (setq
+ res
+ (cons
+ (list (nth 0 elt) (nth 1 elt)
+ (string-to-number (nth 2 elt)) ;; default value
+ (when (string= (nth 3 elt) "1")
+ (string-to-number (nth 4 elt)))
+ (when (string= (nth 5 elt) "1")
+ (string-to-number (nth 6 elt)))
+ (cond
+ ((string= (nth 7 elt) "1")
+ 'toggle)
+ ((string= (nth 8 elt) "1")
+ 'integer)
+ ((string= (nth 9 elt) "1")
+ 'logarithmic)
+ ((string= (nth 10 elt) "1")
+ 'output))) res)
+ elt (nthcdr 11 elt)
+ count (1- count)))
+ (reverse res))))
+ (mapcar (lambda (str) (split-string str ","))
+ (split-string string "\n"))))
+
+(defeci cs-set-audio-format
+ ((format (ecasound-read-from-minibuffer
+ "Audio format" "s16_le,2,44100,i") "%s"))
+ "Set the default sample parameters for currently selected chainsetup.
+For example cd-quality audio would be \"16,2,44100\"."
+ :pcomplete doc)
+
+(defeci cop-register)
+(defeci preset-register)
+(defeci ctrl-register)
+
+(defeci cop-status)
+
+(defeci ladspa-register)
+
+(defun ecasound-read-copp (copp)
+ "Interactively read one chainop parameter."
+ (let* ((completion-ignore-case t)
+ (default (format "%S" (nth 2 copp)))
+ (answer
+ (read-from-minibuffer
+ (concat
+ (car copp)
+ " (default " default "): ")
+ nil nil nil nil
+ default)))
+ (if (and answer (not (string= answer "")))
+ answer
+ default)))
+
+;;; ChainOp Editor
+
+(defvar ecasound-cop-edit-mode-map
+ (let ((map (make-keymap)))
+ (set-keymap-parent map widget-keymap)
+ map))
+
+(define-derived-mode ecasound-cop-edit-mode fundamental-mode "COP-edit"
+ "A major mode for editing ecasound chain operators.")
+
+(defun ecasound-cop-edit ()
+ "Edit the chain operator settings of the current session interactively.
+This is done using the ecasound-cop widget."
+ (interactive)
+ (let ((cb (current-buffer))
+ (chains (eci-cop-status)))
+ (switch-to-buffer-other-window (generate-new-buffer "*cop-edit*"))
+ (ecasound-cop-edit-mode)
+ (mapc
+ (lambda (chain)
+ (widget-insert (format "Chain %s:\n" (car chain)))
+ (mapc
+ (lambda (cop)
+ (apply 'widget-create 'ecasound-cop :buffer cb cop))
+ (cdr chain)))
+ chains)
+ (widget-setup)
+ (goto-char (point-min))))
+
+(define-widget 'ecasound-cop 'default
+ "A Chain Operator.
+:children is a list of ecasound-copp widgets."
+ :convert-widget
+ (lambda (widget)
+ (let ((args (widget-get widget :args)))
+ (when args
+ (widget-put widget :tag (car args))
+ (widget-put widget :cop-number (nth 1 args))
+ (widget-put widget :args (cddr args))))
+ widget)
+ :value-create
+ (lambda (widget)
+ (widget-put
+ widget :children
+ (mapcar
+ (lambda (copp-arg)
+ (apply 'widget-create-child-and-convert
+ widget '(ecasound-copp) copp-arg))
+ (widget-get widget :args))))
+ :format-handler
+ (lambda (widget escape)
+ (cond
+ ((eq escape ?i)
+ (widget-put
+ widget :cop-select
+ (widget-create-child-value
+ widget '(ecasound-cop-select) (widget-get widget :cop-number))))))
+ :format "%i %t\n%v")
+
+(define-widget 'ecasound-cop-select 'link
+ "Select this chain operator parameter."
+ :help-echo "RET to select."
+ :button-prefix ""
+ :button-suffix ""
+ :format "%[%v.%]"
+ :action
+ (lambda (widget &rest ignore)
+ (let ((buffer (widget-get (widget-get widget :parent) :buffer)))
+ (eci-cop-select (widget-value widget) buffer))))
+
+;;;; A Chain Operator Parameter Widget.
+
+; This is used as a component of the cop widget.
+
+(define-widget 'ecasound-copp 'number
+ "A Chain operator parameter."
+ :action 'ecasound-copp-action
+ :convert-widget 'ecasound-copp-convert
+ :format " %i %v (%t)\n"
+ :format-handler 'ecasound-copp-format-handler
+ :size 10)
+
+(defun ecasound-copp-convert (widget)
+ "Convert args."
+ (let ((args (widget-get widget :args)))
+ (when args
+ (widget-put widget :tag (car args))
+ (widget-put widget :copp-number (nth 1 args))
+ (widget-put widget :value (nth 2 args))
+ (widget-put widget :args nil)))
+ widget)
+
+(defun ecasound-copp-format-handler (widget escape)
+ (cond
+ ((eq escape ?i)
+ (widget-put
+ widget
+ :copp-select
+ (widget-create-child-value
+ widget
+ '(ecasound-copp-select)
+ (widget-get widget :copp-number))))
+ ((eq escape ?s)
+ (widget-put
+ widget
+ :slider
+ (widget-create-child-value
+ widget
+ '(slider)
+ (string-to-number (widget-get widget :value)))))))
+
+(defun ecasound-copp-action (widget &rest ignore)
+ "Sets WIDGETs value in its associated ecasound buffer."
+ (let ((buffer (widget-get (widget-get widget :parent) :buffer)))
+ (if (widget-apply widget :match (widget-value widget))
+ (progn
+ (eci-cop-set (widget-get (widget-get widget :parent) :cop-number)
+ (widget-get widget :copp-number)
+ (widget-value widget)
+ buffer))
+ (message "Invalid"))))
+
+(defvar ecasound-copp-select-keymap
+ (let ((map (copy-keymap widget-keymap)))
+ (define-key map "+" 'ecasound-copp-increase)
+ (define-key map "-" 'ecasound-copp-decrease)
+ map)
+ "Keymap used inside an copp.")
+
+(defun ecasound-copp-increase (pos &optional event)
+ (interactive "@d")
+ ;; BUG, if we do this, the field is suddently no longer editable, why???
+ (let ((widget (widget-get (widget-at pos) :parent)))
+ (widget-value-set
+ widget
+ (+ (widget-value widget) 1))
+ (widget-apply widget :action)
+ (widget-setup)))
+
+(defun ecasound-copp-decrease (pos &optional event)
+ (interactive "@d")
+ (let ((widget (widget-get (widget-at pos) :parent)))
+ (widget-value-set
+ widget
+ (- (widget-value widget) 1))
+ (widget-apply widget :action)
+ (widget-setup)))
+
+(define-widget 'ecasound-copp-select 'link
+ "Select this chain operator parameter."
+ :help-echo "RET to select, +/- to set in steps."
+ :keymap ecasound-copp-select-keymap
+ :format "%[%v%]"
+ :action 'ecasound-copp-select-action)
+
+(defun ecasound-copp-select-action (widget &rest ignore)
+ "Selects WIDGET in its associated ecasound buffer."
+ (let ((buffer (widget-get (widget-get (widget-get widget :parent) :parent)
+ :buffer)))
+ (eci-copp-select (widget-get widget :value) buffer)))
+
+(define-widget 'slider 'default
+ "A slider."
+ :action 'widget-slider-action
+ :button-prefix ""
+ :button-suffix ""
+ :format "(%[%v%])"
+ :keymap
+ (let ((map (copy-keymap widget-keymap)))
+ (define-key map "\C-m" 'widget-slider-press)
+ (define-key map "+" 'widget-slider-increase)
+ (define-key map "-" 'widget-slider-decrease)
+ map)
+ :value-create 'widget-slider-value-create
+ :value-delete 'ignore
+ :value-get 'widget-value-value-get
+ :size 70
+ :value 0)
+
+(defun widget-slider-press (pos &optional event)
+ "Invoke slider at POS."
+ (interactive "@d")
+ (let ((button (get-char-property pos 'button)))
+ (if button
+ (widget-apply-action
+ (widget-value-set
+ button
+ (- pos (overlay-start (widget-get button :button-overlay))))
+ event)
+ (let ((command (lookup-key widget-global-map (this-command-keys))))
+ (when (commandp command)
+ (call-interactively command))))))
+
+(defun widget-slider-increase (pos &optional event)
+ "Increase slider at POS."
+ (interactive "@d")
+ (widget-slider-change pos #'+ 1 event))
+
+(defun widget-slider-decrease (pos &optional event)
+ "Decrease slider at POS."
+ (interactive "@d")
+ (widget-slider-change pos #'- 1 event))
+
+(defun widget-slider-change (pos function value &optional event)
+ "Change slider at POS by applying FUNCTION to old-value and VALUE."
+ (let ((button (get-char-property pos 'button)))
+ (if button
+ (widget-apply-action
+ (widget-value-set button (apply function (widget-value button) value))
+ event)
+ (let ((command (lookup-key widget-global-map (this-command-keys))))
+ (when (commandp command)
+ (call-interactively command))))))
+
+(defun widget-slider-action (widget &rest ignore)
+ "Set the current :parent value to :value."
+ (widget-value-set (widget-get widget :parent)
+ (widget-value widget)))
+
+(defun widget-slider-value-create (widget)
+ "Create a sliders value."
+ (let ((size (widget-get widget :size))
+ (value (string-to-int (format "%.0f" (widget-get widget :value))))
+ (from (point)))
+ (insert-char ?\ value)
+ (insert-char ?\| 1)
+ (insert-char ?\ (- size value 1))))
+
+\f
+;;; Ecasound .ewf major mode
+
+(defgroup ecasound-ewf nil
+ "Ecasound .ewf file mode related variables and faces."
+ :prefix "ecasound-ewf-"
+ :group 'ecasound)
+
+(defcustom ecasound-ewf-output-device "/dev/dsp"
+ "*Default output device used for playing .ewf files."
+ :group 'ecasound-ewf
+ :type 'string)
+
+(defface ecasound-ewf-keyword-face '((t (:foreground "IndianRed")))
+ "The face used for highlighting keywords."
+ :group 'ecasound-ewf)
+
+(defface ecasound-ewf-time-face '((t (:foreground "Cyan")))
+ "The face used for highlighting time information."
+ :group 'ecasound-ewf)
+
+(defface ecasound-ewf-file-face '((t (:foreground "Green")))
+ "The face used for highlighting the filname."
+ :group 'ecasound-ewf)
+
+(defface ecasound-ewf-boolean-face '((t (:foreground "Orange")))
+ "The face used for highlighting boolean values."
+ :group 'ecasound-ewf)
+
+(defvar ecasound-ewf-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\t" 'pcomplete)
+ (define-key map "\C-c\C-p" 'ecasound-ewf-play)
+ map)
+ "Keymap for `ecasound-ewf-mode'.")
+
+(defvar ecasound-ewf-mode-syntax-table
+ (let ((st (make-syntax-table)))
+ (modify-syntax-entry ?# "<" st)
+ (modify-syntax-entry ?\n ">" st)
+ st)
+ "Syntax table for `ecasound-ewf-mode'.")
+
+(defvar ecasound-ewf-font-lock-keywords
+ '(("^\\s-*\\(source\\)[^=]+=\\s-*\\(.*\\)$"
+ (1 'ecasound-ewf-keyword-face)
+ (2 'ecasound-ewf-file-face))
+ ("^\\s-*\\(offset\\)[^=]+=\\s-*\\([0-9.]+\\)$"
+ (1 'ecasound-ewf-keyword-face)
+ (2 'ecasound-ewf-time-face))
+ ("^\\s-*\\(start-position\\)[^=]+=\\s-*\\([0-9.]+\\)$"
+ (1 'ecasound-ewf-keyword-face)
+ (2 'ecasound-ewf-time-face))
+ ("^\\s-*\\(length\\)[^=]+=\\s-*\\([0-9.]+\\)$"
+ (1 'ecasound-ewf-keyword-face)
+ (2 'ecasound-ewf-time-face))
+ ("^\\s-*\\(looping\\)[^=]+=\\s-*\\(true\\|false\\)$"
+ (1 'ecasound-ewf-keyword-face)
+ (2 'ecasound-ewf-boolean-face)))
+ "Keyword highlighting specification for `ecasound-ewf-mode'.")
+
+;;;###autoload
+(define-derived-mode ecasound-ewf-mode fundamental-mode "EWF"
+ "A major mode for editing ecasound .ewf files."
+ (set (make-local-variable 'comment-start) "# ")
+ (set (make-local-variable 'comment-start-skip) "#+\\s-*")
+ (set (make-local-variable 'font-lock-defaults)
+ '(ecasound-ewf-font-lock-keywords))
+ (ecasound-ewf-setup-pcomplete))
+
+;;; .ewf-mode pcomplete support
+
+(defun ecasound-ewf-keyword-completion-function ()
+ (pcomplete-here
+ (list "source" "offset" "start-position" "length" "looping")))
+
+(defun pcomplete/ecasound-ewf-mode/source ()
+ (pcomplete-here (pcomplete-entries)))
+
+(defun pcomplete/ecasound-ewf-mode/offset ()
+ (message "insert audio object at offset (seconds) [read,write]")
+ (throw 'pcompleted t))
+
+(defun pcomplete/ecasound-ewf-mode/start-position ()
+ (message "start offset inside audio object (seconds) [read]")
+ (throw 'pcompleted t))
+
+(defun pcomplete/ecasound-ewf-mode/length ()
+ (message "how much of audio object data is used (seconds) [read]")
+ (throw 'pcompleted t))
+
+(defun pcomplete/ecasound-ewf-mode/looping ()
+ (pcomplete-here (list "true" "false")))
+
+(defun ecasound-ewf-parse-arguments ()
+ "Parse whitespace separated arguments in the current region."
+ (let ((begin (save-excursion (beginning-of-line) (point)))
+ (end (point))
+ begins args)
+ (save-excursion
+ (goto-char begin)
+ (while (< (point) end)
+ (skip-chars-forward " \t\n=")
+ (setq begins (cons (point) begins))
+ (let ((skip t))
+ (while skip
+ (skip-chars-forward "^ \t\n=")
+ (if (eq (char-before) ?\\)
+ (skip-chars-forward " \t\n=")
+ (setq skip nil))))
+ (setq args (cons (buffer-substring-no-properties
+ (car begins) (point))
+ args)))
+ (cons (reverse args) (reverse begins)))))
+
+(defun ecasound-ewf-setup-pcomplete ()
+ (set (make-local-variable 'pcomplete-parse-arguments-function)
+ 'ecasound-ewf-parse-arguments)
+ (set (make-local-variable 'pcomplete-command-completion-function)
+ 'ecasound-ewf-keyword-completion-function)
+ (set (make-local-variable 'pcomplete-command-name-function)
+ (lambda ()
+ (pcomplete-arg 'first)))
+ (set (make-local-variable 'pcomplete-arg-quote-list)
+ (list ? )))
+
+;;; Interactive commands
+
+;; FIXME: Make it use ECI.
+(defun ecasound-ewf-play ()
+ (interactive)
+ (let ((ecasound-arguments (list "-c"
+ "-i" buffer-file-name
+ "-o" ecasound-ewf-output-device)))
+ (and (buffer-modified-p)
+ (y-or-n-p "Save file before playing? ")
+ (save-buffer))
+ (ecasound "*Ecasound-ewf Player*")))
+
+(add-to-list 'auto-mode-alist (cons "\\.ewf$" 'ecasound-ewf-mode))
+
+;; Local variables:
+;; mode: outline-minor
+;; outline-regexp: ";;;;* \\|\f"
+;; End:
+
+(provide 'ecasound)
+
+;;; ecasound.el ends here
+
--- /dev/null
+;;; emacs-wiki.el --- Maintain a local Wiki using Emacs-friendly markup
+
+;; Copyright (C) 2001, 2002, 2003 John Wiegley (johnw AT gnu DOT org)
+
+;; Emacs Lisp Archive Entry
+;; Filename: emacs-wiki.el
+;; Version: 2.40
+;; Date: Sun 24-Nov-2002
+;; Keywords: hypermedia
+;; Author: John Wiegley (johnw AT gnu DOT org)
+;; Alex Schroeder (alex AT gnu DOT org)
+;; Maintainer: Damien Elmes (emacswiki AT repose DOT cx)
+;; Description: Maintain Emacs-friendly Wikis in a local directory
+;; URL: http://repose.cx/emacs/wiki
+;; Compatibility: Emacs20, Emacs21, XEmacs21
+
+;; This file is not part of GNU Emacs.
+
+;; The canonical URL for this file is now:
+;; http://repose.cx/emacs/wiki
+;; Older copies and other modules which use emacs-wiki can be found at the
+;; original author's page:
+;; http://www.gci-net.com/users/j/johnw/EmacsResources.html
+
+;; This is free software; you can redistribute it and/or modify it under
+;; the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2, or (at your option) any later
+;; version.
+;;
+;; This is distributed in the hope that it will be useful, but WITHOUT
+;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+;; for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+;; MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; Wiki is a concept, more than a thing. It is a way of creating
+;; document pages using plain text markup and simplified hyperlinking.
+
+;; By typing a name in MixedCase, a hyperlink is automatically created
+;; to the document "MixedCase". Pressing return on that name will
+;; create the file if it doesn't exist, or visit it if it does.
+
+;; The markup used by emacs-wiki is intended to be very friendly to
+;; people familiar with Emacs. Type C-h v emacs-wiki-publishing-markup
+;; after this mode is loaded for how to get started.
+
+;; * Startup
+
+;; To begin using emacs-wiki, put this in your .emacs file:
+
+;; (load "emacs-wiki")
+
+;; Now you can type M-x emacs-wiki-find-file, give it a WikiName (or
+;; just hit return) and start typing!
+
+;; You should also type M-x customize-group, and give the name
+;; "emacs-wiki". Change it to suite your preferences. Each of the
+;; options has its own documentation.
+
+;; * Keystroke summary
+
+;; Here is a summary of keystrokes available in every Wiki buffer:
+
+;; C-c C-a jump to an index of all the Wiki pages
+;; C-c C-b show all pages that reference this page
+;; C-c C-s search for a word in your Wiki pages
+;; C-c C-f jump to another Wiki page; prompts for the name
+;; C-c C-l highlight/refresh the current buffer
+;; C-c C-p publish any Wiki pages that have changed as HTML
+;; C-c C-r rename wiki link at point
+;; C-c C-v change wiki project
+;; C-c C-D delete wiki link at point (binding will only work on X)
+;; C-c = diff this page against the last backup version
+;; TAB move to the next Wiki reference
+;; S-TAB move to the previous Wiki reference
+
+;; * Using pcomplete
+
+;; If you have pcomplete loaded, you can type M-TAB to complete Wiki
+;; names. Hitting M-TAB twice or more time in succession, will cycle
+;; through all of the possibilities. You can download pcomplete from
+;; my Website:
+
+;; http://www.gci-net.com/~johnw/emacs.html
+
+;; * ChangeLog support
+
+;; If you use a ChangeLog (C-x 4 a) within one of your Wiki
+;; directories, it will be used for notifying visitors to your wiki of
+;; recent changes.
+
+;; * Changing title or stylesheet
+
+;; For convenience, if you want to change the visible title, or the
+;; stylesheet, used by a certain Wiki page during HTML publishing,
+;; just put:
+
+;; #title Hello there
+;; #style hello.css
+
+;; at the top of the page.
+
+;; * <lisp> tricks
+
+;; <lisp></lisp> tags can be used, not only to evaluate forms for
+;; insertion at that point, but to influence the publishing process in
+;; many ways. Here's another way to change a page's stylesheet:
+
+;; <lisp>
+;; (ignore
+;; ;; use special.css for this Wiki page
+;; (set (make-variable-buffer-local 'emacs-wiki-style-sheet)
+;; "<link rel=\"stylesheet\" type=\"text/css\" href=\"special.css\">"))
+;; </lisp>
+
+;; The 'ignore' is needed so nothing is inserted where the <lisp> tag
+;; occurred. Also, there should be no blank lines before or after the
+;; tag (to avoid empty paragraphs from being created). The best place
+;; to put this would be at the very top or bottom of the page.
+
+;; * Sub-lists?
+
+;; There is no inherent support for sub-lists, since I couldn't think
+;; of a simple way to do it. But if you really need them, here's a
+;; trick you can use:
+
+;; - Hello
+;; <ul>
+;; <li>There
+;; <li>My friend
+;; </ul>
+
+;;; Thanks
+
+;; Alex Schroeder (alex AT gnu DOT org), current author of "wiki.el".
+;; His latest version is here:
+;; http://www.geocities.com/kensanata/wiki/WikiMode.html
+;;
+;; Frank Gerhardt (Frank.Gerhardt AT web DOT de), author of the original wiki-mode
+;; His latest version is here:
+;; http://www.s.netic.de/fg/wiki-mode/wiki.el
+;;
+;; Thomas Link (<t.link AT gmx DOT at)
+
+;;; Code:
+
+;; The parts of this code, and work to be done:
+;;
+;; * setup emacs-wiki major mode
+;; * generate WikiName list
+;; * utility functions to extract link parts
+;; * open a page
+;; * navigate links in the buffer
+;; * visit a link
+;; * search Wiki pages for text/backlinks
+;; * index generation
+;; * buffer highlighting (using font-lock)
+;; * HTML publishing
+;; - Allow for alternate markup tables: DocBook, xhtml, etc.
+;; - <nop> used in a line of verse doesn't have effect
+;; * HTTP serving (using httpd.el)
+;; - Diffing (look at using highlight-changes-mode and htmlify.el)
+;; - Editing (requires implementing POST method for httpd.el)
+
+(defvar emacs-wiki-version "$Id"
+ "The version of emacs-wiki currently loaded")
+
+(require 'derived)
+
+;; for caddr etc
+;(eval-when-compile (require 'cl))
+
+;; load pcomplete if it's available
+(load "pcomplete" t t)
+
+(defvar emacs-wiki-under-windows-p (memq system-type '(ms-dos windows-nt)))
+
+;;; Options:
+
+(defgroup emacs-wiki nil
+ "Options controlling the behaviour of Emacs Wiki Mode.
+Wiki is a concept, more than a thing. It is a way of creating
+document pages using plain text markup and simplified hyperlinking.
+
+By typing a name in MixedCase, a hyperlink is automatically created
+to the document \"MixedCase\". Pressing return on that name will
+create the file if it doesn't exist, or visit it if it does.
+
+The markup used by emacs-wiki is intended to be very friendly to
+people familiar with Emacs. See the documentation for the variable
+`emacs-wiki-publishing-markup' for a full description."
+ :group 'hypermedia)
+
+(defcustom emacs-wiki-mode-hook
+ (append (if (featurep 'table)
+ '(table-recognize))
+ (unless (featurep 'httpd)
+ '(emacs-wiki-use-font-lock)))
+ "A hook that is run when emacs-wiki mode is entered."
+ :type 'hook
+ :options '(emacs-wiki-use-font-lock
+ emacs-wiki-highlight-buffer
+ flyspell-mode
+ footnote-mode
+ highlight-changes-mode)
+ :group 'emacs-wiki)
+
+;;;###autoload
+(defcustom emacs-wiki-directories '("~/Wiki")
+ "A list of directories where Wiki pages can be found."
+ :require 'emacs-wiki
+ :type '(repeat :tag "Wiki directories" directory)
+ :group 'emacs-wiki)
+
+(defcustom emacs-wiki-default-page "WelcomePage"
+ "Name of the default page used by \\[emacs-wiki-find-file]."
+ :type 'string
+ :group 'emacs-wiki)
+
+(defcustom emacs-wiki-file-ignore-regexp
+ "\\`\\(\\.?#.*\\|.*,v\\|.*~\\|\\.\\.?\\)\\'"
+ "A regexp matching files to be ignored in Wiki directories."
+ :type 'regexp
+ :group 'emacs-wiki)
+
+(defcustom emacs-wiki-ignored-extensions-regexp
+ "\\.\\(bz2\\|gz\\|[Zz]\\)\\'"
+ "A regexp of extensions to omit from the ending of Wiki page name."
+ :type 'string
+ :group 'emacs-wiki)
+
+(defcustom emacs-wiki-interwiki-names
+ '(("GnuEmacs" . "http://www.gnu.org/software/emacs/emacs.html")
+ ("TheEmacsWiki" .
+ (lambda (tag)
+ (concat "http://www.emacswiki.org/cgi-bin/wiki.pl?"
+ (or tag "SiteMap"))))
+ ("MeatballWiki" .
+ (lambda (tag)
+ (concat "http://www.usemod.com/cgi-bin/mb.pl?"
+ (or tag "MeatballWiki")))))
+ "A table of WikiNames that refer to external entities.
+The format of this table is an alist, or series of cons cells.
+Each cons cell must be of the form:
+
+ (WIKINAME . STRING-OR-FUNCTION)
+
+The second part of the cons cell may either be a STRING, which in most
+cases should be a URL, or a FUNCTION. If a function, it will be
+called with one argument: the tag applied to the Interwiki name, or
+nil if no tag was used. If the cdr was a STRING and a tag is used,
+the tag is simply appended.
+
+Here are some examples:
+
+ (\"JohnWiki\" . \"http://alice.dynodns.net/wiki?\")
+
+Referring to [[JohnWiki#EmacsModules]] then really means:
+
+ http://alice.dynodns.net/wiki?EmacsModules
+
+If a function is used for the replacement text, you can get creative
+depending on what the tag is. Tags may contain any alphabetic
+character, any number, % or _. If you need other special characters,
+use % to specify the hex code, as in %2E. All browsers should support
+this."
+ :type '(repeat (cons (string :tag "WikiName")
+ (choice (string :tag "URL") function)))
+ :group 'emacs-wiki)
+
+(defvar emacs-wiki-url-or-name-regexp nil
+ "Matches either a Wiki link or a URL. This variable is auto-generated.")
+
+(defvar emacs-wiki-url-or-name-regexp-group-count nil
+ "Matches either a Wiki link or a URL. This variable is auto-generated.")
+
+(defcustom emacs-wiki-extended-link-regexp
+ "\\[\\[\\([^] \t\n]+\\)\\]\\(\\[\\([^]\n]+\\)\\]\\)?\\]"
+ "Regexp used to match [[extended][links]]."
+ :type 'regexp
+ :group 'emacs-wiki)
+
+(defun emacs-wiki-count-chars (string char)
+ (let ((i 0)
+ (l (length string))
+ (count 0))
+ (while (< i l)
+ (if (eq char (aref string i))
+ (setq count (1+ count)))
+ (setq i (1+ i)))
+ count))
+
+(defun emacs-wiki-set-sym-and-url-regexp (sym value)
+ (setq emacs-wiki-url-or-name-regexp
+ (concat "\\("
+ (if (eq sym 'emacs-wiki-name-regexp)
+ value
+ emacs-wiki-name-regexp) "\\|"
+ (if (eq sym 'emacs-wiki-name-regexp)
+ (if (boundp 'emacs-wiki-url-regexp)
+ emacs-wiki-url-regexp
+ "")
+ value) "\\)")
+ emacs-wiki-url-or-name-regexp-group-count
+ (- (emacs-wiki-count-chars
+ emacs-wiki-url-or-name-regexp ?\() 2))
+ (set sym value))
+
+(defcustom emacs-wiki-name-regexp
+ (concat "\\(" emacs-wiki-extended-link-regexp "\\|"
+ "\\<[A-Z][a-z]+\\([A-Z][a-z]+\\)+\\(#[A-Za-z0-9_%]+\\)?" "\\)")
+ "Regexp used to match WikiNames."
+ :type 'regexp
+ :set 'emacs-wiki-set-sym-and-url-regexp
+ :group 'emacs-wiki)
+
+(defcustom emacs-wiki-url-regexp
+ (concat "\\<\\(https?:/?/?\\|ftp:/?/?\\|gopher://\\|"
+ "telnet://\\|wais://\\|file:/\\|s?news:\\|"
+ "mailto:\\)"
+ "[^] \n \"'()<>[^`{}]*[^] \n \"'()<>[^`{}.,;]+")
+ "A regexp used to match URLs within a Wiki buffer."
+ :type 'regexp
+ :set 'emacs-wiki-set-sym-and-url-regexp
+ :group 'emacs-wiki)
+
+(defcustom emacs-wiki-browse-url-function 'browse-url
+ "Function to call to browse a URL."
+ :type 'function
+ :group 'emacs-wiki)
+
+(defcustom emacs-wiki-grep-command
+ "find %D -type f ! -name '*~' | xargs egrep -n -e \"\\<%W\\>\""
+ "The name of the program to use when grepping for backlinks.
+The string %D is replaced by `emacs-wiki-directories', space-separated.
+The string %W is replaced with the name of the Wiki page.
+
+Note: I highly recommend using glimpse to search large Wikis. To use
+glimpse, install and edit a file called .glimpse_exclude in your home
+directory. Put a list of glob patterns in that file to exclude Emacs
+backup files, etc. Then, run the indexer using:
+
+ glimpseindex -o <list of Wiki directories>
+
+Once that's completed, customize this variable to have the following
+value:
+
+ glimpse -nyi \"%W\"
+
+Your searches will go much, much faster, especially for very large
+Wikis. Don't forget to add a user cronjob to update the index at
+intervals."
+ :type 'string
+ :group 'emacs-wiki)
+
+(defvar emacs-wiki-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [(control ?c) (control ?a)] 'emacs-wiki-index)
+ (define-key map [(control ?c) (control ?f)] 'emacs-wiki-find-file)
+ (define-key map [(control ?c) (control ?b)] 'emacs-wiki-backlink)
+ (define-key map [(control ?c) (control ?s)] 'emacs-wiki-search)
+ (define-key map [(control ?c) (control ?p)] 'emacs-wiki-publish)
+ (define-key map [(control ?c) (control ?v)] 'emacs-wiki-change-project)
+ (define-key map [(control ?c) (control ?r)]
+ 'emacs-wiki-rename-link-at-point)
+ (define-key map [(control ?c) (control ?D)]
+ 'emacs-wiki-delete-link-at-point)
+
+ (define-key map [(control ?c) (control ?l)] 'font-lock-mode)
+
+ (define-key map [(control ?c) ?=]
+ (lambda ()
+ (interactive)
+ (diff-backup buffer-file-name)))
+
+ (define-key map [tab] 'emacs-wiki-next-reference)
+ (define-key map [(control ?i)] 'emacs-wiki-next-reference)
+
+ (if (featurep 'xemacs)
+ (define-key map [(shift tab)] 'emacs-wiki-previous-reference)
+ (define-key map [(shift iso-lefttab)] 'emacs-wiki-previous-reference)
+ (define-key map [(shift control ?i)] 'emacs-wiki-previous-reference))
+
+ (when (featurep 'pcomplete)
+ (define-key map [(meta tab)] 'pcomplete)
+ (define-key map [(meta control ?i)] 'pcomplete))
+
+ map)
+ "Keymap used by Emacs Wiki mode.")
+
+(defvar emacs-wiki-local-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [return] 'emacs-wiki-follow-name-at-point)
+ (define-key map [(control ?m)] 'emacs-wiki-follow-name-at-point)
+ (if (featurep 'xemacs)
+ (define-key map [(button2)] 'emacs-wiki-follow-name-at-mouse)
+ (define-key map [mouse-2] 'emacs-wiki-follow-name-at-mouse)
+ (unless (eq emacs-major-version 21)
+ (set-keymap-parent map emacs-wiki-mode-map)))
+ map)
+ "Local keymap used by emacs-wiki while on a WikiName.")
+
+;; Code:
+
+(defvar emacs-wiki-project nil)
+
+;;;###autoload
+(define-derived-mode emacs-wiki-mode text-mode "Wiki"
+ "An Emacs mode for maintaining a local Wiki database.
+
+Wiki is a hypertext and a content management system: Normal users are
+encouraged to enhance the hypertext by editing and refactoring existing
+wikis and by adding more. This is made easy by requiring a certain way
+of writing the wikis. It is not as complicated as a markup language
+such as HTML. The general idea is to write plain ASCII.
+
+Words with mixed case such as ThisOne are WikiNames. WikiNames are
+links you can follow. If a wiki with that name exists, you will be
+taken there. If such a does not exist, following the link will create
+a new wiki for you to fill. WikiNames for non-existing wikis are
+rendered as links with class \"nonexistent\", and are also displayed
+in a warning color so that you can see wether following the link will
+lead you anywhere or not.
+
+In order to follow a link, hit RET when point is on the link, or use
+mouse-2.
+
+All wikis reside in the `emacs-wiki-directories'.
+
+\\{emacs-wiki-mode-map}"
+ (if emacs-wiki-project
+ (emacs-wiki-change-project emacs-wiki-project))
+ ;; because we're not inheriting from normal-mode, we need to
+ ;; explicitly run file variables if the user wants to
+ (condition-case err
+ (hack-local-variables)
+ (error (message "File local-variables error: %s"
+ (prin1-to-string err))))
+ ;; bootstrap the file-alist, if it's not been read in yet
+ (emacs-wiki-file-alist t)
+ ;; if pcomplete is available, set it up!
+ (when (featurep 'pcomplete)
+ (set (make-variable-buffer-local 'pcomplete-default-completion-function)
+ 'emacs-wiki-completions)
+ (set (make-variable-buffer-local 'pcomplete-command-completion-function)
+ 'emacs-wiki-completions)
+ (set (make-variable-buffer-local 'pcomplete-parse-arguments-function)
+ 'emacs-wiki-current-word)))
+
+(defsubst emacs-wiki-page-file (page &optional no-check-p)
+ "Return a filename if PAGE exists within the current Wiki."
+ (cdr (assoc page (emacs-wiki-file-alist no-check-p))))
+
+(defsubst emacs-wiki-directory-part (path)
+ (directory-file-name (expand-file-name path)))
+
+(defun emacs-wiki-directories-member (&optional directories)
+ "Return non-nil if the current buffer is in `emacs-wiki-directories'."
+ (let ((here (emacs-wiki-directory-part default-directory))
+ (d (or directories emacs-wiki-directories))
+ yes)
+ (while d
+ (if (string= here (emacs-wiki-directory-part (if (consp (car d))
+ (caar d)
+ (car d))))
+ (setq yes (car d) d nil)
+ (setq d (cdr d))))
+ yes))
+
+(defun emacs-wiki-maybe (&optional check-only)
+ "Maybe turn Emacs Wiki mode on for this file."
+ (let ((projs emacs-wiki-projects)
+ (mode-func 'emacs-wiki-mode)
+ project yes)
+ (while (and (not yes) projs)
+ (let* ((projsyms (cdar projs))
+ (pred (assq 'emacs-wiki-predicate projsyms))
+ dirs)
+ (if pred
+ (setq yes (funcall (cdr pred)))
+ (setq dirs (assq 'emacs-wiki-directories projsyms))
+ (if dirs
+ (setq yes (emacs-wiki-directories-member (cdr dirs)))))
+ (if yes
+ (setq project (caar projs)
+ mode-func (or (cdr (assq 'emacs-wiki-major-mode projsyms))
+ mode-func))))
+ (setq projs (cdr projs)))
+ (setq yes (or yes (emacs-wiki-directories-member)))
+ (if (and yes (not check-only))
+ (let ((emacs-wiki-project project))
+ (funcall mode-func)))
+ yes))
+
+(add-hook 'find-file-hooks 'emacs-wiki-maybe)
+
+;;; Support WikiName completion using pcomplete
+
+(defun emacs-wiki-completions ()
+ "Return a list of possible completions names for this buffer."
+ (while (pcomplete-here
+ (mapcar 'car (append (emacs-wiki-file-alist)
+ emacs-wiki-interwiki-names)))))
+
+(defun emacs-wiki-current-word ()
+ (let ((end (point)))
+ (save-restriction
+ (save-excursion
+ (skip-chars-backward "^\\[ \t\n")
+ (narrow-to-region (point) end))
+ (pcomplete-parse-buffer-arguments))))
+
+;;; Return an list of known wiki names and the files they represent.
+
+(defsubst emacs-wiki-time-less-p (t1 t2)
+ "Say whether time T1 is less than time T2."
+ (or (< (car t1) (car t2))
+ (and (= (car t1) (car t2))
+ (< (nth 1 t1) (nth 1 t2)))))
+
+(defun emacs-wiki-page-name (&optional name)
+ "Return the canonical form of the Wiki page name.
+All this means is that certain extensions, like .gz, are removed."
+ (save-match-data
+ (unless name
+ (setq name buffer-file-name))
+ (if name
+ (let ((page (file-name-nondirectory name)))
+ (if (string-match emacs-wiki-ignored-extensions-regexp page)
+ (replace-match "" t t page)
+ page)))))
+
+(defun emacs-wiki-page-title (&optional name)
+ "Return the canonical form of the Wiki page name.
+All this means is that certain extensions, like .gz, are removed."
+ (or emacs-wiki-current-page-title
+ (emacs-wiki-prettify-title (emacs-wiki-page-name name))))
+
+(defvar emacs-wiki-file-alist nil)
+
+(defun emacs-wiki-file-alist (&optional no-check-p)
+ "Return possible Wiki filenames in `emacs-wiki-directories'.
+On UNIX, this list is only updated if one of the directories' contents
+have changed. On Windows, it is always reread from disk."
+ (let* ((file-alist (assoc emacs-wiki-current-project
+ emacs-wiki-file-alist))
+ (dirs emacs-wiki-directories)
+ (d dirs) last-mod)
+ (unless (or emacs-wiki-under-windows-p no-check-p)
+ (while d
+ (let ((mod-time (nth 5 (file-attributes (car d)))))
+ (if (or (null last-mod)
+ (and mod-time (emacs-wiki-time-less-p last-mod mod-time)))
+ (setq last-mod mod-time)))
+ (setq d (cdr d))))
+ (if (or (and no-check-p (cadr file-alist))
+ (not (or emacs-wiki-under-windows-p
+ (null (cddr file-alist))
+ (null last-mod)
+ (emacs-wiki-time-less-p (cddr file-alist) last-mod))))
+ (cadr file-alist)
+ (if file-alist
+ (setcdr (cdr file-alist) last-mod)
+ (setq file-alist (cons emacs-wiki-current-project (cons nil last-mod))
+ emacs-wiki-file-alist (cons file-alist emacs-wiki-file-alist)))
+ (save-match-data
+ (setcar
+ (cdr file-alist)
+ (let* ((names (list t))
+ (lnames names))
+ (while dirs
+ (if (file-readable-p (car dirs))
+ (let ((files (directory-files (car dirs) t nil t)))
+ (while files
+ (unless
+ (or (file-directory-p (car files))
+ (string-match emacs-wiki-file-ignore-regexp
+ (file-name-nondirectory
+ (car files))))
+ (setcdr lnames
+ (cons (cons (emacs-wiki-page-name (car files))
+ (car files)) nil))
+ (setq lnames (cdr lnames)))
+ (setq files (cdr files)))))
+ (setq dirs (cdr dirs)))
+ (cdr names)))))))
+
+(defun emacs-wiki-complete-alist ()
+ "Return equivalent of calling (emacs-wiki-file-alist) for all projects."
+ (let ((emacs-wiki-current-project "_CompositeFileList")
+ (emacs-wiki-directories
+ (copy-alist emacs-wiki-directories))
+ (projs emacs-wiki-projects))
+ (while projs
+ (let* ((projsyms (cdar projs))
+ (dirs (cdr (assq 'emacs-wiki-directories projsyms))))
+ (while dirs
+ (add-to-list 'emacs-wiki-directories (car dirs))
+ (setq dirs (cdr dirs))))
+ (setq projs (cdr projs)))
+ (emacs-wiki-file-alist)))
+
+;; Utility functions to extract parts of a Wiki name
+
+(defvar emacs-wiki-serving-p nil
+ "Non-nil when emacs-wiki is serving a wiki page directly.")
+
+(defsubst emacs-wiki-transform-name (name)
+ "Transform NAME as per `emacs-wiki-publishing-transforms', returning NAME"
+ (save-match-data
+ (mapc (function
+ (lambda (elt)
+ (let ((reg (car elt))
+ (rep (cdr elt)))
+ (when (string-match reg name)
+ (setq name (replace-match rep t nil name))))))
+ emacs-wiki-publishing-transforms)
+ name))
+
+(defsubst emacs-wiki-published-name (name &optional current)
+ "Return the externally visible NAME for a wiki page, possibly transformed
+ via `emacs-wiki-publishing-transforms'. If CURRENT is provided, convert any
+ path to be relative to it"
+ (emacs-wiki-transform-name
+ (progn
+ (when current
+ (setq name (file-relative-name name
+ (file-name-directory
+ (emacs-wiki-transform-name current)))))
+ (concat (if emacs-wiki-serving-p
+ (unless (string-match "\\?" name) "wiki?")
+ emacs-wiki-publishing-file-prefix)
+ name
+ (if emacs-wiki-serving-p
+ (if emacs-wiki-current-project
+ (concat "&project=" emacs-wiki-current-project))
+ emacs-wiki-publishing-file-suffix)))))
+
+(defsubst emacs-wiki-published-file (&optional file)
+ "Return the filename of the published file. Since this is based on the
+ published-name, it will be filtered through
+ `emacs-wiki-publishing-transforms'"
+ (expand-file-name (emacs-wiki-published-name (emacs-wiki-page-name
+ file))
+ emacs-wiki-publishing-directory))
+
+(defcustom emacs-wiki-publishing-transforms nil
+ "A list of cons cells mapping regexps to replacements, which is applied when
+generating the published name from the wiki file name. The replacements
+run in order so you can chain them together.
+
+An example is how I publish the emacs-wiki documentation. The emacs-wiki
+homepage is in a file called EmacsWiki. With the following settings I can
+publish directly to my webserver via tramp (the first rule catches 'WikiMarkup'
+for instance):
+
+(setq emacs-wiki-publishing-directory \"/webserver:/var/www/\")
+(setq emacs-wiki-publishing-transforms
+ ((\".*Wiki.*\" . \"emacs/wiki/\\&\")
+ (\"EmacsWiki\\|WelcomePage\" . \"index\")))
+
+Then when trying to publish a page EmacsWiki:
+
+(emacs-wiki-published-file \"EmacsWiki\")
+
+You get:
+
+\"/webserver:/var/www/emacs/wiki/index.html\""
+ :type '(repeat
+ (cons
+ (regexp :tag "String to match")
+ (string :tag "Replacement string")))
+ :group 'emacs-wiki-publish)
+
+(defsubst emacs-wiki-wiki-url-p (name)
+ "Return non-nil if NAME is a URL."
+ (save-match-data
+ (string-match emacs-wiki-url-regexp name)))
+
+(defun emacs-wiki-wiki-visible-name (wiki-name)
+ "Return the visible part of a Wiki link.
+This only really means something if [[extended][links]] are involved."
+ (save-match-data
+ (let ((name wiki-name))
+ (if (string-match emacs-wiki-extended-link-regexp name)
+ (if (match-string 2 name)
+ (setq name (match-string 3 name))
+ (setq name (match-string 1 name))))
+ (if (and (not (emacs-wiki-wiki-url-p name))
+ (string-match "#" name))
+ (if (= 0 (match-beginning 0))
+ (setq name (emacs-wiki-page-name))
+ (let ((base (substring name 0 (match-beginning 0))))
+ (if (assoc base emacs-wiki-interwiki-names)
+ (setq name (concat (substring name 0 (match-beginning 0))
+ ":" (substring name (match-end 0))))
+ (setq name base)))))
+ name)))
+
+(defun emacs-wiki-wiki-tag (wiki-name)
+ (save-match-data
+ (if (string-match "#" wiki-name)
+ (substring wiki-name (match-end 0)))))
+
+(defun emacs-wiki-wiki-link-target (wiki-name)
+ "Return the target of a Wiki link. This might include anchor tags."
+ (save-match-data
+ (let ((name wiki-name) lookup)
+ (if (string-match "^\\[\\[\\([^]]+\\)\\]" name)
+ (setq name (match-string 1 name)))
+ (if (and emacs-wiki-interwiki-names
+ (string-match "\\`\\([^#]+\\)\\(#\\(.+\\)\\)?\\'" name)
+ (setq lookup (assoc (match-string 1 name)
+ emacs-wiki-interwiki-names)))
+ (let ((tag (match-string 3 name))
+ (target (cdr lookup)))
+ (if (stringp target)
+ (setq name (concat target tag))
+ (setq name (funcall target tag))))
+ (if (and (> (length name) 0)
+ (eq (aref name 0) ?#))
+ (setq name (concat (emacs-wiki-page-name) name))))
+ name)))
+
+(defun emacs-wiki-wiki-base (wiki-name)
+ "Find the WikiName or URL mentioned by a Wiki link.
+This means without tags, in the case of a WikiName."
+ (save-match-data
+ (let ((file (emacs-wiki-wiki-link-target wiki-name)))
+ (if (emacs-wiki-wiki-url-p file)
+ file
+ (if (string-match "#" file)
+ (substring file 0 (match-beginning 0))
+ file)))))
+
+;;; Open a Wiki page (with completion)
+
+(defvar emacs-wiki-history-list nil)
+
+(defun emacs-wiki-read-name (file-alist &optional prompt)
+ "Read the name of a valid Wiki page from minibuffer, with completion."
+ (let* ((default emacs-wiki-default-page)
+ (str (completing-read
+ (format "%s(default: %s) " (or prompt "Wiki page: ") default)
+ file-alist nil nil nil 'emacs-wiki-history-list)))
+ (if (or (null str) (= (length str) 0))
+ default
+ str)))
+
+;;;###autoload
+(defun emacs-wiki-find-file (wiki &optional command directory)
+ "Open the Emacs Wiki page WIKI by name.
+If COMMAND is non-nil, it is the function used to visit the file.
+If DIRECTORY is non-nil, it is the directory in which the Wiki page
+will be created if it does not already exist."
+ (interactive
+ (list
+ (let ((num (prefix-numeric-value current-prefix-arg)))
+ (if (< num 16)
+ (let* ((file-alist (if (= num 4)
+ (emacs-wiki-complete-alist)
+ (emacs-wiki-file-alist)))
+ (name (emacs-wiki-read-name file-alist)))
+ (cons name (cdr (assoc name file-alist))))
+ (let ((name (read-file-name "Open wiki file: ")))
+ (cons name name))))))
+ (unless (interactive-p)
+ (setq wiki (cons wiki
+ (cdr (assoc wiki (emacs-wiki-file-alist))))))
+ ;; At this point, `wiki' is (GIVEN-PAGE FOUND-FILE).
+ (if (cdr wiki)
+ (let ((buffer (funcall (or command 'find-file) (cdr wiki))))
+ (if (= (prefix-numeric-value current-prefix-arg) 16)
+ (with-current-buffer buffer
+ (set (make-variable-buffer-local 'emacs-wiki-directories)
+ (cons (file-name-directory (cdr wiki))
+ emacs-wiki-directories))
+ (set (make-variable-buffer-local 'emacs-wiki-file-alist) nil)))
+ buffer)
+ (let* ((dirname (or directory
+ (emacs-wiki-maybe t)
+ (car emacs-wiki-directories)))
+ (filename (expand-file-name (car wiki) dirname)))
+ (unless (file-exists-p dirname)
+ (make-directory dirname t))
+ (funcall (or command 'find-file) filename))))
+
+;;; Navigate/visit links or URLs. Use TAB, S-TAB and RET (or mouse-2).
+
+(defun emacs-wiki-next-reference ()
+ "Move forward to next Wiki link or URL, cycling if necessary."
+ (interactive)
+ (let ((case-fold-search nil)
+ (cycled 0) pos)
+ (save-excursion
+ (if (emacs-wiki-link-at-point)
+ (goto-char (match-end 0)))
+ (while (< cycled 2)
+ (if (re-search-forward emacs-wiki-url-or-name-regexp nil t)
+ (setq pos (match-beginning 0)
+ cycled 2)
+ (goto-char (point-min))
+ (setq cycled (1+ cycled)))))
+ (if pos
+ (goto-char pos))))
+
+(defun emacs-wiki-previous-reference ()
+ "Move backward to the next Wiki link or URL, cycling if necessary.
+This function is not entirely accurate, but it's close enough."
+ (interactive)
+ (let ((case-fold-search nil)
+ (cycled 0) pos)
+ (save-excursion
+ (while (< cycled 2)
+ (if (re-search-backward emacs-wiki-url-or-name-regexp nil t)
+ (setq pos (point)
+ cycled 2)
+ (goto-char (point-max))
+ (setq cycled (1+ cycled)))))
+ (if pos
+ (goto-char pos))))
+
+(defun emacs-wiki-visit-link (link-name)
+ "Visit the URL or link named by LINK-NAME."
+ (let ((link (emacs-wiki-wiki-link-target link-name)))
+ (if (emacs-wiki-wiki-url-p link)
+ (funcall emacs-wiki-browse-url-function link)
+ ;; The name list is current since the last time the buffer was
+ ;; highlighted
+ (let* ((base (emacs-wiki-wiki-base link-name))
+ (file (emacs-wiki-page-file base t))
+ (tag (and (not (emacs-wiki-wiki-url-p link))
+ (emacs-wiki-wiki-tag link))))
+ (if (null file)
+ (find-file base)
+ (find-file file)
+ (when tag
+ (goto-char (point-min))
+ (re-search-forward (concat "^\\.?#" tag) nil t)))))))
+
+(unless (fboundp 'line-end-position)
+ (defsubst line-end-position (&optional N)
+ (save-excursion (end-of-line N) (point))))
+
+(unless (fboundp 'line-beginning-position)
+ (defsubst line-beginning-position (&optional N)
+ (save-excursion (beginning-of-line N) (point))))
+
+(unless (fboundp 'match-string-no-properties)
+ (defalias 'match-string-no-properties 'match-string))
+
+(defun emacs-wiki-link-at-point (&optional pos)
+ "Return non-nil if a URL or Wiki link name is at point."
+ (if (or (null pos)
+ (and (char-after pos)
+ (not (eq (char-syntax (char-after pos)) ? ))))
+ (let ((case-fold-search nil)
+ (here (or pos (point))))
+ (save-excursion
+ (goto-char here)
+ (skip-chars-backward "^'\"<>{}( \t\n")
+ (or (looking-at emacs-wiki-url-or-name-regexp)
+ (and (search-backward "[[" (line-beginning-position) t)
+ (looking-at emacs-wiki-name-regexp)
+ (<= here (match-end 0))))))))
+
+(defun emacs-wiki-follow-name-at-point ()
+ "Visit the link at point, or insert a newline if none."
+ (interactive)
+ (if (emacs-wiki-link-at-point)
+ (emacs-wiki-visit-link (match-string 0))
+ (error "There is no valid link at point")))
+
+(defun emacs-wiki-follow-name-at-mouse (event)
+ "Visit the link at point, or yank text if none."
+ (interactive "e")
+ (save-excursion
+ (cond ((fboundp 'event-window) ; XEmacs
+ (set-buffer (window-buffer (event-window event)))
+ (and (event-point event) (goto-char (event-point event))))
+ ((fboundp 'posn-window) ; Emacs
+ (set-buffer (window-buffer (posn-window (event-start event))))
+ (goto-char (posn-point (event-start event)))))
+ (if (emacs-wiki-link-at-point)
+ (emacs-wiki-visit-link (match-string 0)))))
+
+(defun emacs-wiki-rename-link (link-name new-name)
+ (when (emacs-wiki-wiki-url-p link-name)
+ (error "Can't rename a URL"))
+ (let* ((base (emacs-wiki-wiki-base link-name))
+ (file (emacs-wiki-page-file base t)))
+ (if (null file)
+ (rename-file base new-name)
+ (rename-file file new-name))))
+
+(defun emacs-wiki-rename-link-at-point ()
+ "Rename the link under point, and the location it points to. This does not
+ work with URLs"
+ (interactive "*")
+ (let (new-name old-name)
+ (if (emacs-wiki-link-at-point)
+ (progn
+ (setq old-name (match-string 0))
+ ;; emacs21 leaves the local keymap on this string, so we must strip
+ ;; properties so the user can hit return to exit minibuf
+ (set-text-properties 0 (length old-name) nil old-name)
+ (setq new-name (read-from-minibuffer "Rename to: " old-name))
+ (emacs-wiki-rename-link old-name new-name)
+ ;; at this point, the file would have been successfully renamed, so
+ ;; it's safe to change to link name now
+ (replace-match new-name nil t))
+ (error "There is no valid link at point"))))
+
+(defun emacs-wiki-delete-link (link-name)
+ "Delete the file which link-name corresponds to"
+ (when (emacs-wiki-wiki-url-p link-name)
+ (error "Can't rename a URL"))
+ (let* ((base (emacs-wiki-wiki-base link-name))
+ (file (emacs-wiki-page-file base t)))
+ (if (null file)
+ (delete-file base)
+ (delete-file file))))
+
+(defun emacs-wiki-delete-link-at-point ()
+ "Delete the link under point, and the location it points to. This does not
+ work with URLs"
+ (interactive "*")
+ (let (name)
+ (if (emacs-wiki-link-at-point)
+ (progn
+ (setq name (match-string 0))
+ (when (yes-or-no-p (concat "Delete "
+ name "? You can not undo this. "))
+ (emacs-wiki-delete-link name)
+ (replace-match "" nil t)))
+ (error "There is no valid link at point"))))
+
+;;; Find text in Wiki pages, or pages referring to the current page
+
+(defvar emacs-wiki-search-history nil)
+
+(defun emacs-wiki-grep (string &optional grep-command)
+ "Grep for STRING in the Wiki directories. GREP-COMMAND if passed will
+ supplant emacs-wiki-grep-command."
+ (require 'compile)
+ (let ((str (or grep-command emacs-wiki-grep-command))
+ (dirs (mapconcat (lambda (dir)
+ (shell-quote-argument (expand-file-name dir)))
+ emacs-wiki-directories " ")))
+ (while (string-match "%W" str)
+ (setq str (replace-match string t t str)))
+ (while (string-match "%D" str)
+ (setq str (replace-match dirs t t str)))
+ (compile-internal str "No more search hits" "search"
+ nil grep-regexp-alist)))
+
+(defun emacs-wiki-search (text)
+ "Search for the given TEXT string in the Wiki directories."
+ (interactive
+ (list (let ((str (concat emacs-wiki-grep-command)) pos)
+ (when (string-match "%W" str)
+ (setq pos (match-beginning 0))
+ (unless (featurep 'xemacs)
+ (setq pos (1+ pos)))
+ (setq str (replace-match "" t t str)))
+ (read-from-minibuffer "Search command: "
+ (cons str pos)
+ nil nil 'emacs-wiki-search-history))))
+ (emacs-wiki-grep nil text))
+
+(defun emacs-wiki-backlink ()
+ "Grep for the current pagename in all the Wiki directories."
+ (interactive)
+ (emacs-wiki-grep (emacs-wiki-page-name)))
+
+;;; Generate an index of all known Wiki pages
+
+(defun emacs-wiki-generate-index (&optional as-list exclude-private)
+ "Generate an index of all Wiki pages."
+ (let ((project emacs-wiki-current-project))
+ (with-current-buffer (get-buffer-create "*Wiki Index*")
+ (erase-buffer)
+ (if project
+ (emacs-wiki-change-project project))
+ (let ((files (sort (copy-alist (emacs-wiki-file-alist))
+ (function
+ (lambda (l r)
+ (string-lessp (car l) (car r))))))
+ file)
+ (while files
+ (unless (and exclude-private
+ (emacs-wiki-private-p (caar files)))
+ (insert (if as-list "- " "") "[[" (caar files) "]]\n"))
+ (setq files (cdr files))))
+ (current-buffer))))
+
+(defun emacs-wiki-index ()
+ "Display an index of all known Wiki pages."
+ (interactive)
+ (message "Generating Wiki index...")
+ (pop-to-buffer (emacs-wiki-generate-index))
+ (goto-char (point-min))
+ (emacs-wiki-mode)
+ (message "Generating Wiki index...done"))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Emacs Wiki Highlighting
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defgroup emacs-wiki-highlight nil
+ "Options controlling the behaviour of Emacs Wiki highlighting.
+See `emacs-wiki-highlight-buffer' for more information."
+ :group 'emacs-wiki)
+
+(defun emacs-wiki-make-faces ()
+ (mapc (lambda (newsym)
+ (let (num)
+ (setq num newsym)
+ (setq newsym (intern (concat "emacs-wiki-header-"
+ (int-to-string num))))
+ (cond
+ ((featurep 'xemacs)
+ (eval `(defface ,newsym
+ '((t (:size
+ ,(nth (1- num) '("24pt" "18pt" "14pt" "12pt"))
+ :bold t)))
+ "emacs-wiki header face"
+ :group 'emacs-wiki-highlight)))
+ ((< emacs-major-version 21)
+ (copy-face 'default newsym))
+ (t
+ (eval `(defface ,newsym
+ '((t (:height ,(1+ (* 0.1 (- 5 num)))
+ :inherit variable-pitch
+ :weight bold)))
+ "emacs-wiki header face"
+ :group 'emacs-wiki-highlight))))))
+ '(1 2 3 4 5 6)))
+(emacs-wiki-make-faces)
+
+(defface emacs-wiki-link-face
+ '((((class color) (background light))
+ (:foreground "green" :underline "green" :bold t))
+ (((class color) (background dark))
+ (:foreground "cyan" :underline "cyan" :bold t))
+ (t (:bold t)))
+ "Face for Wiki cross-references."
+ :group 'emacs-wiki-highlight)
+
+(defface emacs-wiki-bad-link-face
+ '((((class color) (background light))
+ (:foreground "red" :underline "red" :bold t))
+ (((class color) (background dark))
+ (:foreground "coral" :underline "coral" :bold t))
+ (t (:bold t)))
+ "Face for bad Wiki cross-references."
+ :group 'emacs-wiki-highlight)
+
+(defcustom emacs-wiki-highlight-buffer-hook nil
+ "A hook run after a region is highlighted.
+Each function receives three arguments: BEG END VERBOSE.
+BEG and END mark the range being highlighted, and VERBOSE specifies
+whether progress messages should be displayed to the user."
+ :type 'hook
+ :group 'emacs-wiki-highlight)
+
+(defcustom emacs-wiki-inline-images (and (not (featurep 'xemacs))
+ (>= emacs-major-version 21)
+ window-system)
+ "If non-nil, inline locally available images within Wiki pages."
+ :type 'boolean
+ :group 'emacs-wiki-highlight)
+
+(defcustom emacs-wiki-image-regexp
+ "\\.\\(eps\\|gif\\|jp\\(e?g\\)\\|p\\(bm\\|ng\\)\\|tiff\\|x\\([bp]m\\)\\)\\'"
+ "A link matching this regexp will be published inline as an image. Remember
+that it must be matched as a link first - so use either [[CamelCaps]] or
+include a leading slash - [[./text]]. An example:
+
+ [[./wife.jpg][A picture of my wife]]
+
+If you omit the description, the alt tag of the resulting HTML buffer will be
+the name of the file."
+ :type 'regexp
+ :group 'emacs-wiki)
+
+(defcustom emacs-wiki-file-regexp
+ "[/?]\\|\\.\\(html?\\|pdf\\|el\\|zip\\|txt\\|tar\\)\\(\\.\\(gz\\|bz2\\)\\)?\\'"
+ "A link matching this regexp will be regarded as a link to a file. Remember
+that it must be matched as a link first - so use either [[CamelCaps]] or
+include a leading slash - [[./text]]"
+ :type 'regexp
+ :group 'emacs-wiki)
+
+(defcustom emacs-wiki-tag-regexp
+ "<\\([^/ \t\n][^ \t\n</>]*\\)\\(\\s-+[^<>]+[^</>]\\)?\\(/\\)?>"
+ "A regexp used to find XML-style tags within a buffer when publishing.
+Group 1 should be the tag name, group 2 the properties, and group
+3 the optional immediate ending slash."
+ :type 'regexp
+ :group 'emacs-wiki)
+
+(defcustom emacs-wiki-inline-relative-to 'emacs-wiki-publishing-directory
+ "The name of a symbol which records the location relative to where images
+ should be found. The default assumes that when editing, the images can be
+ found in the publishing directory. Another sensible default is
+ `default-directory', which will try and find the images relative to the
+ local page. You can use this to store images in wikidir/images, and
+ maintain a parallel copy on the remote host."
+ :type 'symbol
+ :group 'emacs-wiki)
+
+(defcustom emacs-wiki-markup-tags
+ '(("example" t nil t emacs-wiki-example-tag)
+ ("verbatim" t nil t emacs-wiki-verbatim-tag)
+ ("nowiki" t nil t emacs-wiki-nowiki-tag)
+ ("verse" t nil nil emacs-wiki-verse-tag)
+ ("numbered" t nil nil emacs-wiki-numbered-tag)
+ ("nop" nil nil t emacs-wiki-nop-tag)
+ ("contents" nil t nil emacs-wiki-contents-tag)
+ ("c-source" t t t emacs-wiki-c-source-tag))
+ "A list of tag specifications, for specially marking up Wiki text.
+XML-style tags are the best way to add custom markup to Emacs Wiki.
+This is easily accomplished by customizing this list of markup tags.
+
+For each entry, the name of the tag is given, whether it expects a
+closing tag and/or an optional set of attributes, if the handler
+function can also highlight the tag, and a function that performs
+whatever action is desired within the delimited region.
+
+The tags themselves are deleted during publishing, although not during
+highlighting, before the function is called. The function is called
+with three arguments, the beginning and end of the region surrounded
+by the tags (including the tags themselves, in the case of
+highlighting). The third argument indicates whether the purpose of
+the call is to highlight the region, or mark it up for publishing. If
+properties are allowed, they are passed as a fourth argument in the
+form of an alist. The `end' argument to the function is always a
+marker.
+
+Point is always at the beginning of the region within the tags, when
+the function is called. Wherever point is when the function finishes
+is where tag markup/highlighting will resume.
+
+These tag rules are processed once at the beginning of markup, and
+once at the end, to catch any tags which may have been inserted
+in-between. For highlighting, they are processed as they occur, in
+the order they occur, once per text region.
+
+Here is a summary of the default tags. This includes the dangerous
+tags listed in `emacs-wiki-dangerous-tags', which may not be used by
+outsiders.
+
+ verbatim
+ Protects against highlighting and wiki interpretation, and escapes any
+ characters which have special meaning to the publishing format. For HTML,
+ this means characters like '<' are escaped as HTML entities.
+
+ example
+ Like verbatim, but typesets in HTML using the <pre> tag, with
+ class=example, so whitespace formatting is preserved.
+
+ nowiki
+ Inhibits wiki markup, but does not do any escaping to the underlying
+ publishing medium. Useful for embedding HTML, PHP, etc.
+
+ verse
+ Typesets like a normal paragraph, but without word-wrapping.
+ That is, whitespace is preserved.
+
+ redirect
+ Using the \"url\" attribute, you can specify that a page should
+ redirect to another page. The remaining contents of the page will
+ not be published. The optional \"delay\" attribute specifies how
+ long to wait before redirecting.
+
+ nop
+ When placed before a WikiLink, it will prevent that WikiLink from
+ being treated as such. Good for names like DocBook.
+
+ contents
+ Produces a compact table of contents for any section heading at the
+ same level or lower than the next section header encountered.
+ Optional \"depth\" attribute specifies how deep the table of
+ contents should go.
+
+ lisp
+ Evaluate the region as a Lisp form, and displays the result. When
+ highlighting, the `display' text property is used, preserving the
+ underlying text. Turn off font-lock mode if you wish to edit it.
+
+ command
+ Pass the region to a command interpretor and insert the result,
+ guarding it from any further expansion. Optional \"file\"
+ attribute specifies the shell or interpretor to use. If none is
+ given, and `emacs-wiki-command-tag-file' has not been configured,
+ Eshell is used.
+
+ python, perl
+ Pass the region to the Python or Perl language interpretor, and
+ insert the result.
+
+ c-source
+ Markup the region as C or C++ source code, using the c2html
+ program, if available. Optional boolean attribute \"numbered\"
+ will cause source lines to be numbered.
+
+ Note: If c2html is not available, the region will be converted to
+ HTML friendly text (i.e., <> turns into <>), and placed in a
+ <pre> block. In this case, line numbering is not available.
+
+ bookmarks
+ Insert bookmarks at the location of the tag from the given
+ bookmarks file. Required attribute \"file\" specifies which file
+ to read from, and the optional attribute \"type\" may be one of:
+ adr (for Opera), lynx, msie, ns, xbel or xmlproc. The default type
+ is \"xbel\". The optional attribute \"folder\" may be used to
+ specify which folder (and its children) should be inserted.
+
+ Note that xml-parse.el version 1.5 (available from my website) and
+ the xbel-utils package (available at least to Debian users) is
+ required for this feature to work."
+ :type '(repeat (list (string :tag "Markup tag")
+ (boolean :tag "Expect closing tag" :value t)
+ (boolean :tag "Parse attributes" :value nil)
+ (boolean :tag "Highlight tag" :value nil)
+ function))
+ :group 'emacs-wiki-highlight)
+
+(defcustom emacs-wiki-dangerous-tags
+ '(("redirect" t t nil emacs-wiki-redirect-tag)
+ ("lisp" t nil t emacs-wiki-lisp-tag)
+ ("command" t t t emacs-wiki-command-tag)
+ ("python" t t t emacs-wiki-python-tag)
+ ("perl" t t t emacs-wiki-perl-tag)
+ ("bookmarks" nil t nil emacs-wiki-bookmarks-tag))
+ "A list of tag specifications, for specially marking up Wiki text.
+These tags are dangerous -- meaning represent a gaping security hole
+-- and therefore are not available to outsiders who happen to edit a
+Wiki page"
+ :type '(repeat (list (string :tag "Markup tag")
+ (boolean :tag "Expect closing tag" :value t)
+ (boolean :tag "Parse attributes" :value nil)
+ (boolean :tag "Highlight tag" :value nil)
+ function))
+ :group 'emacs-wiki-highlight)
+
+(defvar emacs-wiki-highlight-regexp nil)
+(defvar emacs-wiki-highlight-vector nil)
+
+(defun emacs-wiki-configure-highlighting (sym val)
+ (setq emacs-wiki-highlight-regexp
+ (concat "\\(" (mapconcat (function
+ (lambda (rule)
+ (if (symbolp (car rule))
+ (symbol-value (car rule))
+ (car rule)))) val "\\|") "\\)")
+ emacs-wiki-highlight-vector (make-vector 128 nil))
+ (let ((rules val))
+ (while rules
+ (if (eq (cadr (car rules)) t)
+ (let ((i 0) (l 128))
+ (while (< i l)
+ (unless (aref emacs-wiki-highlight-vector i)
+ (aset emacs-wiki-highlight-vector i
+ (nth 2 (car rules))))
+ (setq i (1+ i))))
+ (aset emacs-wiki-highlight-vector (cadr (car rules))
+ (nth 2 (car rules))))
+ (setq rules (cdr rules))))
+ (set sym val))
+
+(defsubst emacs-wiki-highlight-ok-context-p (beg end str)
+ "Ensures whitespace or punctuation comes before the position BEG, and
+ after the string STR. A search-forward is done for STR, bounding by END, and
+ the position of the end of the match is returned if in the correct context."
+ (save-excursion
+ (let ((len (length str)))
+ (and
+ (setq end (search-forward str end t))
+ ;; post end, want eob or whitespace/punctuation
+ (or (> (skip-syntax-forward ". " (1+ end)) 0)
+ (eq nil (char-after end)))
+ (goto-char (- end len))
+ ;; pre end, no whitespace
+ (eq (skip-syntax-backward " " (- end len 1)) 0)
+ (goto-char (+ beg len))
+ ;; post beg, no whitespace
+ (eq (skip-syntax-forward " " (+ beg len 1)) 0)
+ (or (backward-char len) t) ;; doesn't return anything useful
+ ;; pre beg, want sob or whitespace/punctuation
+ (or (< (skip-syntax-backward ". " (1- beg)) 0)
+ (eq nil (char-before beg)))
+ end))))
+
+(defun emacs-wiki-multiline-maybe (beg end &optional predicate)
+ "If region between beg-end is a multi-line region, and the optional
+ predicate is true, font lock the current region as multi-line. Predicate is
+ called with the excursion saved."
+ (when (and (or (eq (char-before end) ?\n)
+ (> (count-lines beg end) 1))
+ (or (not predicate)
+ (save-excursion (funcall predicate beg end))))
+ (save-excursion
+ ;; mark whole lines as a multiline font-lock
+ (goto-char beg)
+ (setq beg (line-beginning-position))
+ (goto-char end)
+ (setq end (line-end-position))
+ (add-text-properties beg end '(font-lock-multiline t))
+ t)))
+
+(defun emacs-wiki-highlight-emphasized ()
+ ;; here we need to check four different points - the start and end of the
+ ;; leading *s, and the start and end of the trailing *s. we allow the
+ ;; outsides to be surrounded by whitespace or punctuation, but no word
+ ;; characters, and the insides must not be surrounded by whitespace or
+ ;; punctuation. thus the following are valid:
+ ;; " *foo bar* "
+ ;; "**foo**,"
+ ;; and the following is invalid:
+ ;; "** testing **"
+ (let* ((beg (match-beginning 0))
+ (e1 (match-end 0))
+ (leader (- e1 beg))
+ (end end)
+ b2 e2 face)
+ ;; if it's a header
+ (unless (save-excursion
+ (goto-char beg)
+ (when (save-match-data (looking-at "^\\*\\{1,3\\} "))
+ (add-text-properties
+ (line-beginning-position) (line-end-position)
+ (list 'face
+ (intern (concat "emacs-wiki-header-"
+ (int-to-string (1+ leader))))))
+ t))
+ ;; it might be an normal, emphasised piece of text
+ (when (and
+ (setq e2 (emacs-wiki-highlight-ok-context-p
+ beg end (buffer-substring-no-properties beg e1)))
+ (setq b2 (match-beginning 0)))
+ (cond ((= leader 1) (setq face 'italic))
+ ((= leader 2) (setq face 'bold))
+ ((= leader 3) (setq face 'bold-italic)))
+ (add-text-properties beg e1 '(invisible t intangible t))
+ (add-text-properties e1 b2 (list 'face face))
+ (add-text-properties b2 e2 '(invisible t intangible t)))
+ (emacs-wiki-multiline-maybe
+ beg end
+ ;; ensures we only mark the region as multiline if it's correctly
+ ;; delimited at the start
+ (lambda (beg end)
+ (goto-char (1+ beg))
+ (eq (skip-syntax-forward " " (1+ beg)) 0)
+ (or (backward-char) t)
+ (or (< (skip-syntax-backward ". " (1- beg)) 0)
+ (eq nil (char-before beg))))))))
+
+(defun emacs-wiki-highlight-underlined ()
+ (let ((start (- (point) 2))
+ end)
+ (when (setq end (emacs-wiki-highlight-ok-context-p start end "_"))
+ (add-text-properties start (+ start 1) '(invisible t intangible t))
+ (add-text-properties (+ start 1) (- end 1) '(face underline))
+ (add-text-properties (- end 1) end '(invisible t intangible t)))))
+
+(defun emacs-wiki-highlight-verbatim ()
+ (let ((start (- (point) 2))
+ end)
+ (when (setq end (emacs-wiki-highlight-ok-context-p start end "="))
+ (search-forward "=" end t))))
+
+(defcustom emacs-wiki-highlight-markup
+ `(;; render in teletype and suppress further parsing
+ ("=[^\t =]" ?= emacs-wiki-highlight-verbatim)
+
+ ;; make emphasized text appear emphasized
+ ("\\*+" ?* emacs-wiki-highlight-emphasized)
+
+ ;; make underlined text appear underlined
+ ("_[^ \t_]" ?_ emacs-wiki-highlight-underlined)
+
+ ;; make quadruple quotes invisible
+ ("''''" ?\'
+ ,(function
+ (lambda ()
+ (add-text-properties (match-beginning 0) (match-end 0)
+ '(invisible t intangible t)))))
+
+ ("^#title" ?\# emacs-wiki-highlight-title)
+
+ (emacs-wiki-url-or-name-regexp t emacs-wiki-highlight-link)
+
+ ;; highlight any markup tags encountered
+ (emacs-wiki-tag-regexp ?\< emacs-wiki-highlight-custom-tags))
+ "Expressions to highlight an Emacs Wiki buffer.
+These are arranged in a rather special fashion, so as to be as quick as
+possible.
+
+Each element of the list is itself a list, of the form:
+
+ (LOCATE-REGEXP TEST-CHAR MATCH-FUNCTION)
+
+LOCATE-REGEXP is a partial regexp, and should be the smallest possible
+regexp to differentiate this rule from other rules. It may also be a
+symbol containing such a regexp. The buffer region is scanned only
+once, and LOCATE-REGEXP indicates where the scanner should stop to
+look for highlighting possibilities.
+
+TEST-CHAR is a char or t. The character should match the beginning
+text matched by LOCATE-REGEXP. These chars are used to build a vector
+for fast MATCH-FUNCTION calling.
+
+MATCH-FUNCTION is the function called when a region has been
+identified. It is responsible for adding the appropriate text
+properties to change the appearance of the buffer.
+
+This markup is used to modify the appearance of the original text to
+make it look more like the published HTML would look (like making some
+markup text invisible, inlining images, etc).
+
+font-lock is used to apply the markup rules, so that they can happen
+on a deferred basis. They are not always accurate, but you can use
+\\[font-lock-fontifty-block] near the point of error to force
+fontification in that area.
+
+Lastly, none of the regexp should contain grouping elements that will
+affect the match data results."
+ :type '(repeat
+ (list :tag "Highlight rule"
+ (choice (regexp :tag "Locate regexp")
+ (symbol :tag "Regexp symbol"))
+ (choice (character :tag "Confirm character")
+ (const :tag "Default rule" t))
+ function))
+ :set 'emacs-wiki-configure-highlighting
+ :group 'emacs-wiki-highlight)
+
+(defvar font-lock-mode nil)
+(defvar font-lock-multiline nil)
+
+(defun emacs-wiki-use-font-lock ()
+ (set (make-local-variable 'font-lock-multiline) 'undecided)
+ (set (make-local-variable 'font-lock-defaults)
+ `(nil t nil nil 'beginning-of-line
+ (font-lock-fontify-region-function . emacs-wiki-highlight-region)
+ (font-lock-unfontify-region-function
+ . emacs-wiki-unhighlight-region)))
+ (set (make-local-variable 'font-lock-fontify-region-function)
+ 'emacs-wiki-highlight-region)
+ (set (make-local-variable 'font-lock-unfontify-region-function)
+ 'emacs-wiki-unhighlight-region)
+ (font-lock-mode t))
+
+(defun emacs-wiki-mode-flyspell-verify ()
+ "Return t if the word at point should be spell checked."
+ (let* ((word-pos (1- (point)))
+ (props (text-properties-at word-pos)))
+ (not (or (bobp)
+ (memq 'display props)
+ (if (and font-lock-mode (cadr (memq 'fontified props)))
+ (memq (cadr (memq 'face props))
+ '(emacs-wiki-link-face emacs-wiki-bad-link-face))
+ (emacs-wiki-link-at-point word-pos))))))
+
+(put 'emacs-wiki-mode 'flyspell-mode-predicate
+ 'emacs-wiki-mode-flyspell-verify)
+
+(defun emacs-wiki-eval-lisp (form)
+ "Evaluate the given form and return the result as a string."
+ (require 'pp)
+ (save-match-data
+ (let ((object (eval (read form))))
+ (cond
+ ((stringp object) object)
+ ((and (listp object)
+ (not (eq object nil)))
+ (let ((string (pp-to-string object)))
+ (substring string 0 (1- (length string)))))
+ ((numberp object)
+ (number-to-string object))
+ ((eq object nil) "")
+ (t
+ (pp-to-string object))))))
+
+(defun emacs-wiki-highlight-buffer ()
+ "Re-highlight the entire Wiki buffer."
+ (interactive)
+ (emacs-wiki-highlight-region (point-min) (point-max) t))
+
+(defun emacs-wiki-highlight-region (beg end &optional verbose)
+ "Apply highlighting according to `emacs-wiki-highlight-markup'.
+Note that this function should NOT change the buffer, nor should any
+of the functions listed in `emacs-wiki-highlight-markup'."
+ (let ((buffer-undo-list t)
+ (inhibit-read-only t)
+ (inhibit-point-motion-hooks t)
+ (inhibit-modification-hooks t)
+ (modified-p (buffer-modified-p))
+ deactivate-mark)
+ (unwind-protect
+ (save-excursion
+ (save-restriction
+ (widen)
+ ;; check to see if we should expand the beg/end area for
+ ;; proper multiline matches
+ (when (and font-lock-multiline
+ (> beg (point-min))
+ (get-text-property (1- beg) 'font-lock-multiline))
+ ;; We are just after or in a multiline match.
+ (setq beg (or (previous-single-property-change
+ beg 'font-lock-multiline)
+ (point-min)))
+ (goto-char beg)
+ (setq beg (line-beginning-position)))
+ (when font-lock-multiline
+ (setq end (or (text-property-any end (point-max)
+ 'font-lock-multiline nil)
+ (point-max))))
+ (goto-char end)
+ (setq end (line-beginning-position 2))
+ ;; Undo any fontification in the area.
+ (font-lock-unfontify-region beg end)
+ ;; And apply fontification based on `emacs-wiki-highlight-markup'
+ (let ((len (float (- end beg)))
+ (case-fold-search nil))
+ (goto-char beg)
+ (while
+ (and (< (point) end)
+ (re-search-forward emacs-wiki-highlight-regexp end t))
+ (if verbose
+ (message "Highlighting buffer...%d%%"
+ (* (/ (float (- (point) beg)) len) 100)))
+ (funcall (aref emacs-wiki-highlight-vector
+ (char-after (match-beginning 0)))))
+ (run-hook-with-args 'emacs-wiki-highlight-buffer-hook
+ beg end verbose)
+ (if verbose (message "Highlighting buffer...done")))))
+ (set-buffer-modified-p modified-p))))
+
+(defun emacs-wiki-unhighlight-region (begin end &optional verbose)
+ "Remove all visual highlights in the buffer (except font-lock)."
+ (let ((buffer-undo-list t)
+ (inhibit-read-only t)
+ (inhibit-point-motion-hooks t)
+ (inhibit-modification-hooks t)
+ (modified-p (buffer-modified-p))
+ deactivate-mark)
+ (unwind-protect
+ (remove-text-properties
+ begin end '(face nil font-lock-multiline nil
+ invisible nil intangible nil display nil
+ mouse-face nil keymap nil help-echo nil))
+ (set-buffer-modified-p modified-p))))
+
+(eval-when-compile
+ (defvar end))
+
+(defun emacs-wiki-multiline-maybe (beg end &optional predicate)
+ "If region between beg-end is a multi-line region, and the optional
+ predicate is true, font lock the current region as multi-line. Predicate is
+ called with the excursion saved."
+ (when (and (or (eq (char-before end) ?\n)
+ (> (count-lines beg end) 1))
+ (or (not predicate)
+ (save-excursion (funcall predicate beg end))))
+ (save-excursion
+ ;; mark whole lines as a multiline font-lock
+ (goto-char beg)
+ (setq beg (line-beginning-position))
+ (goto-char end)
+ (setq end (line-end-position))
+ (add-text-properties beg end '(font-lock-multiline t))
+ t)))
+
+(defvar emacs-wiki-keymap-property
+ (if (or (featurep 'xemacs)
+ (>= emacs-major-version 21))
+ 'keymap
+ 'local-map))
+
+(defsubst emacs-wiki-link-properties (help-str &optional face)
+ (append (if face
+ (list 'face face 'rear-nonsticky t
+ emacs-wiki-keymap-property emacs-wiki-local-map)
+ (list 'invisible t 'intangible t 'rear-nonsticky t
+ emacs-wiki-keymap-property emacs-wiki-local-map))
+ (list 'mouse-face 'highlight
+ 'help-echo help-str
+ emacs-wiki-keymap-property emacs-wiki-local-map)))
+
+(defun emacs-wiki-highlight-link ()
+ (if (eq ?\[ (char-after (match-beginning 0)))
+ (if (and emacs-wiki-inline-images
+ (save-match-data
+ (string-match emacs-wiki-image-regexp (match-string 4))))
+ (emacs-wiki-inline-image (match-beginning 0) (match-end 0)
+ (match-string 4) (match-string 6))
+ (let* ((link (match-string-no-properties 4))
+ (invis-props (emacs-wiki-link-properties link))
+ (props (emacs-wiki-link-properties link 'emacs-wiki-link-face)))
+ (if (match-string 6)
+ (progn
+ (add-text-properties (match-beginning 0)
+ (match-beginning 6) invis-props)
+ (add-text-properties (match-beginning 6) (match-end 6) props)
+ (add-text-properties (match-end 6) (match-end 0) invis-props))
+ (add-text-properties (match-beginning 0)
+ (match-beginning 4) invis-props)
+ (add-text-properties (match-beginning 4) (match-end 0) props)
+ (add-text-properties (match-end 4) (match-end 0) invis-props)))
+ (goto-char (match-end 0)))
+ (if (and emacs-wiki-inline-images
+ (save-match-data
+ (string-match emacs-wiki-image-regexp (match-string 0))))
+ (emacs-wiki-inline-image (match-beginning 0) (match-end 0)
+ (match-string 0))
+ (add-text-properties
+ (match-beginning 0) (match-end 0)
+ (emacs-wiki-link-properties
+ (match-string-no-properties 0)
+ (if (let ((base (emacs-wiki-wiki-base (match-string 0))))
+ (or (emacs-wiki-page-file base t)
+ (save-match-data
+ (string-match "\\(/\\|\\`[a-z]\\{3,6\\}:\\)" base))))
+ 'emacs-wiki-link-face
+ 'emacs-wiki-bad-link-face)))
+ (goto-char (match-end 0)))))
+
+(defun emacs-wiki-inline-image (beg end url &optional desc)
+ "Inline locally available images."
+ (let ((filename
+ (cond
+ ((string-match "\\`file:\\(.+\\)" url)
+ (match-string 1 url))
+ ((string-match "/" url)
+ (expand-file-name url (symbol-value
+ emacs-wiki-inline-relative-to))))))
+ (if (and filename (file-readable-p filename))
+ (add-text-properties beg end (list 'display (create-image filename)
+ 'help-echo (or desc url))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Emacs Wiki Publishing (to HTML by default)
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defgroup emacs-wiki-publish nil
+ "Options controlling the behaviour of Emacs Wiki publishing.
+See `emacs-wiki-publish' for more information."
+ :group 'emacs-wiki)
+
+(defcustom emacs-wiki-maintainer (concat "mailto:webmaster@" (system-name))
+ "URL where the maintainer can be reached."
+ :type 'string
+ :group 'emacs-wiki-publish)
+
+(defcustom emacs-wiki-home-page emacs-wiki-default-page
+ "Title of the Wiki Home page."
+ :type 'string
+ :group 'emacs-wiki-publish)
+
+(defcustom emacs-wiki-index-page "WikiIndex"
+ "Title of the Wiki Index page."
+ :type 'string
+ :group 'emacs-wiki-publish)
+
+(defcustom emacs-wiki-downcase-title-words
+ '("the" "and" "at" "on" "of" "for" "in" "an" "a")
+ "Strings that should be downcased in a Wiki page title."
+ :type '(repeat string)
+ :group 'emacs-wiki-publish)
+
+(defcustom emacs-wiki-use-mode-flags (not emacs-wiki-under-windows-p)
+ "If non-nil, use file mode flags to determine page permissions.
+Otherwise the regexps in `emacs-wiki-private-pages' and
+`emacs-wiki-editable-pages' are used."
+ :type 'boolean
+ :group 'emacs-wiki-publish)
+
+(defcustom emacs-wiki-private-pages nil
+ "A list of regexps to exclude from public view.
+This variable only applies if `emacs-wiki-use-mode-flags' is nil."
+ :type '(choice (const nil) (repeat regexp))
+ :group 'emacs-wiki-publish)
+
+(defcustom emacs-wiki-editable-pages nil
+ "A list of regexps of pages that may be edited via HTTP.
+This variable only applies if `emacs-wiki-use-mode-flags' is nil."
+ :type '(choice (const nil) (repeat regexp))
+ :group 'emacs-wiki-publish)
+
+(defcustom emacs-wiki-publishing-directory "~/WebWiki"
+ "Directory where all wikis are published to."
+ :type 'directory
+ :group 'emacs-wiki-publish)
+
+(defcustom emacs-wiki-publishing-file-prefix ""
+ "This prefix will be prepended to all wiki names when publishing."
+ :type 'string
+ :group 'emacs-wiki-publish)
+
+(defcustom emacs-wiki-publishing-file-suffix ".html"
+ "This suffix will be appended to all wiki names when publishing."
+ :type 'string
+ :group 'emacs-wiki-publish)
+
+(defcustom emacs-wiki-before-markup-hook nil
+ "A hook run in the buffer where markup is done, before it is done."
+ :type 'hook
+ :group 'emacs-wiki-publish)
+
+(defcustom emacs-wiki-after-markup-hook nil
+ "A hook run in the buffer where markup is done, after it is done."
+ :type 'hook
+ :group 'emacs-wiki-publish)
+
+(defcustom emacs-wiki-meta-http-equiv "Content-Type"
+ "The http-equiv attribute used for the HTML <meta> tag."
+ :type 'string
+ :group 'emacs-wiki-publish)
+
+(defcustom emacs-wiki-meta-content-type "text/html"
+ "The content type used for the HTML <meta> tag."
+ :type 'string
+ :group 'emacs-wiki-publish)
+
+(defcustom emacs-wiki-meta-content-coding
+ (if (featurep 'mule)
+ 'detect
+ "iso-8859-1")
+ "If set to the symbol 'detect, use `emacs-wiki-coding-map' to try
+ and determine the HTML charset from emacs's coding. If set to a string, this
+ string will be used to force a particular charset"
+ :type '(choice string symbol)
+ :group 'emacs-wiki-publish)
+
+(defcustom emacs-wiki-charset-default "iso-8859-1"
+ "The default HTML meta charset to use if no translation is found in
+ `emacs-wiki-coding-map'"
+ :type 'string
+ :group 'emacs-wiki-publish)
+
+(defcustom emacs-wiki-coding-default 'iso-8859-1
+ "The default emacs coding use if no special characters are found"
+ :type 'symbol
+ :group 'emacs-wiki-publish)
+
+(defcustom emacs-wiki-coding-map
+ '((iso-2022-jp "iso-2022-jp")
+ (utf-8 "utf-8")
+ (japanese-iso-8bit "euc-jp"))
+ "An alist mapping emacs coding systems to appropriate HTML charsets.
+ Use the base name of the coding system (ie, without the -unix)"
+ :type '(alist :key-type coding-system :value-type (group string))
+ :group 'emacs-wiki-publish)
+
+(defcustom emacs-wiki-redirect-delay 1
+ "The number of seconds to delay before doing a page redirect."
+ :type 'integer
+ :group 'emacs-wiki-publish)
+
+(defvar emacs-wiki-current-page-title nil
+ "Current page title, used instead of buffer name if non-nil.
+This is usually set by code called by `emacs-wiki-publishing-markup'.
+It should never be changed globally.")
+
+(defcustom emacs-wiki-anchor-on-word nil
+ "When true, anchors surround the closest word. This allows you
+to select them in a browser (ie, for pasting), but has the
+side-effect of marking up headers in multiple colours if your
+header style is different to your link style."
+ :type 'boolean
+ :group 'emacs-wiki-publish)
+
+(defcustom emacs-wiki-publishing-header
+ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\">
+<html>
+ <head>
+ <title><lisp>(emacs-wiki-page-title)</lisp></title>
+ <meta name=\"generator\" content=\"emacs-wiki.el\">
+ <meta http-equiv=\"<lisp>emacs-wiki-meta-http-equiv</lisp>\"
+ content=\"<lisp>emacs-wiki-meta-content</lisp>\">
+ <link rev=\"made\" href=\"<lisp>emacs-wiki-maintainer</lisp>\">
+ <link rel=\"home\" href=\"<lisp>(emacs-wiki-published-name
+ emacs-wiki-home-page)</lisp>\">
+ <link rel=\"index\" href=\"<lisp>(emacs-wiki-published-name
+ emacs-wiki-index-page)</lisp>\">
+ <lisp>emacs-wiki-style-sheet</lisp>
+ </head>
+ <body>
+ <h1><lisp>(emacs-wiki-page-title)</lisp></h1>
+ <!-- Page published by Emacs Wiki begins here -->\n"
+ "Text to prepend to a wiki being published.
+This text may contain <lisp> markup tags."
+ :type 'string
+ :group 'emacs-wiki-publish)
+
+(defcustom emacs-wiki-publishing-footer
+ "
+ <!-- Page published by Emacs Wiki ends here -->
+ <div class=\"navfoot\">
+ <hr>
+ <table width=\"100%\" border=\"0\" summary=\"Footer navigation\">
+ <tr>
+ <td width=\"33%\" align=\"left\">
+ <lisp>
+ (if buffer-file-name
+ (concat
+ \"<span class=\\\"footdate\\\">Updated: \"
+ (format-time-string emacs-wiki-footer-date-format
+ (nth 5 (file-attributes buffer-file-name)))
+ (and emacs-wiki-serving-p
+ (emacs-wiki-editable-p (emacs-wiki-page-name))
+ (concat
+ \" / \"
+ (emacs-wiki-link-href
+ (concat \"editwiki?\" (emacs-wiki-page-name))
+ \"Edit\")))
+ \"</span>\"))
+ </lisp>
+ </td>
+ <td width=\"34%\" align=\"center\">
+ <span class=\"foothome\">
+ <lisp>
+ (concat
+ (and (emacs-wiki-page-file emacs-wiki-home-page t)
+ (not (emacs-wiki-private-p emacs-wiki-home-page))
+ (concat
+ (emacs-wiki-link-href emacs-wiki-home-page \"Home\")
+ \" / \"))
+ (emacs-wiki-link-href emacs-wiki-index-page \"Index\")
+ (and (emacs-wiki-page-file \"ChangeLog\" t)
+ (not (emacs-wiki-private-p \"ChangeLog\"))
+ (concat
+ \" / \"
+ (emacs-wiki-link-href \"ChangeLog\" \"Changes\"))))
+ </lisp>
+ </span>
+ </td>
+ <td width=\"33%\" align=\"right\">
+ <lisp>
+ (if emacs-wiki-serving-p
+ (concat
+ \"<span class=\\\"footfeed\\\">\"
+ (emacs-wiki-link-href \"searchwiki?get\" \"Search\")
+ (and buffer-file-name
+ (concat
+ \" / \"
+ (emacs-wiki-link-href
+ (concat \"searchwiki?q=\" (emacs-wiki-page-name))
+ \"Referrers\")))
+ \"</span>\"))
+ </lisp>
+ </td>
+ </tr>
+ </table>
+ </div>
+ </body>
+</html>\n"
+ "Text to append to a wiki being published.
+This text may contain <lisp> markup tags."
+ :type 'string
+ :group 'emacs-wiki-publish)
+
+(defcustom emacs-wiki-footer-date-format "%Y-%m-%d"
+ "Format of current date for `emacs-wiki-publishing-footer'.
+This string must be a valid argument to `format-time-string'."
+ :type 'string
+ :group 'emacs-wiki-publish)
+
+(defcustom emacs-wiki-style-sheet
+ "<style type=\"text/css\">
+a.nonexistent {
+ font-weight: bold;
+ background-color: #F8F8F8; color: #FF2222;
+}
+
+a.nonexistent:visited {
+ background-color: #F8F8F8; color: #FF2222;
+}
+
+body {
+ background: white; color: black;
+ margin-left: 5%; margin-right: 5%;
+ margin-top: 3%;
+}
+
+em { font-style: italic; }
+strong { font-weight: bold; }
+
+ul { list-style-type: disc }
+
+dl.contents { margin-top: 0; }
+dt.contents { margin-bottom: 0; }
+
+p.verse {
+ white-space: pre;
+ margin-left: 5%;
+}
+
+pre {
+ white-space: pre;
+ font-family: monospace;
+ margin-left: 5%;
+}
+</style>"
+ "The style sheet used for each wiki page.
+This can either be an inline stylesheet, using <style></style> tags,
+or an external stylesheet reference using a <link> tag.
+
+Here is an example of using a <link> tag:
+
+ <link rel=\"stylesheet\" type=\"text/css\" href=\"emacs-wiki.css\">"
+ :type 'string
+ :group 'emacs-wiki-publish)
+
+(defvar emacs-wiki-publishing-p nil
+ "Set to t while Wiki pages are being published.
+This can be used by <lisp> tags to know when HTML is being generated.")
+
+(defcustom emacs-wiki-block-groups-regexp
+ "\\(h[1-9r]\\|[oud]l\\|table\\|center\\|blockquote\\|pre\\)[^>]*"
+ "This regexp identifies HTML tag which defines their own blocks.
+That is, they do not need to be surrounded by <p>."
+ :type 'regexp
+ :group 'emacs-wiki-publish)
+
+(defcustom emacs-wiki-table-attributes "border=\"2\" cellpadding=\"5\""
+ "The attribute to be used with HTML <table> tags.
+Note that since emacs-wiki support direct insertion of HTML tags, you
+can easily create any kind of table you want, as long as every line
+begins at column 0 (to prevent it from being blockquote'd). To make
+really ANYTHING you want, use this idiom:
+
+ <verbatim>
+ <table>
+ [... contents of my table, in raw HTML ...]
+ </verbatim></table>
+
+It may look strange to have the tags out of sequence, but remember
+that verbatim is processed long before table is even seen."
+ :type 'string
+ :group 'emacs-wiki-publish)
+
+(defcustom emacs-wiki-report-threshhold 100000
+ "If a Wiki file is this size or larger, report publishing progress."
+ :type 'integer
+ :group 'emacs-wiki-publish)
+
+(defcustom emacs-wiki-publishing-markup
+ (list
+ ["&\\([-A-Za-z_#0-9]+\\);" 0 emacs-wiki-markup-entity]
+
+ ;; change the displayed title or the stylesheet for a given page
+ ["\\`#\\(title\\|style\\)\\s-+\\(.+\\)\n+" 0
+ emacs-wiki-markup-initial-directives]
+
+ ;; process any markup tags
+ [emacs-wiki-tag-regexp 0 emacs-wiki-markup-custom-tags]
+
+ ;; emphasized or literal text
+ ["\\(^\\|[-[ \t\n<('`\"]\\)\\(=[^= \t\n]\\|_[^_ \t\n]\\|\\*+[^* \t\n]\\)"
+ 2 emacs-wiki-markup-word]
+
+ ;; headings, outline-mode style
+ ["^\\(\\*+\\)\\s-+" 0 emacs-wiki-markup-heading]
+
+ ;; define anchor points
+ ["^#\\([A-Za-z0-9_%]+\\)\\s-*" 0 emacs-wiki-markup-anchor]
+
+ ;; horizontal rule, or section separator
+ ["^----+" 0 "<hr>"]
+
+ ;; footnotes section is separated by a horizontal rule in HTML
+ ["^\\(\\* \\)?Footnotes:?\\s-*" 0 "<hr>\n<p>\n"]
+ ;; footnote definition/reference (def if at beginning of line)
+ ["\\[\\([1-9][0-9]*\\)\\]" 0 emacs-wiki-markup-footnote]
+
+ ;; don't require newlines between numbered and unnumbered lists.
+ ;; This must come before paragraphs are calculated, so that any
+ ;; extra newlines added will be condensed.
+ ["^\\s-*\\(-\\|[0-9]+\\.\\)" 1 "\n\\1"]
+
+ ;; the beginning of the buffer begins the first paragraph
+ ["\\`\n*" 0 "<p>\n"]
+ ;; plain paragraph separator
+ ["\n\\([ \t]*\n\\)+" 0 "\n\n</p>\n\n<p>\n"]
+
+ ;; if table.el was loaded, allow for pretty tables. otherwise only
+ ;; simple table markup is supported, nothing fancy. use | to
+ ;; separate cells, || to separate header elements, and ||| for
+ ;; footer elements
+ (vector
+ (if (featurep 'table)
+ "^\\(\\s-*\\)\\(\\+[-+]+\\+[\n\r \t]+|\\)"
+ "^\\s-*\\(\\([^|\n]+\\(|+\\)\\s-*\\)+\\)\\([^|\n]+\\)?$")
+ 1 'emacs-wiki-markup-table)
+
+ ;; unnumbered List items begin with a -. numbered list items
+ ;; begin with number and a period. definition lists have a
+ ;; leading term separated from the body with ::. centered
+ ;; paragraphs begin with at least six columns of whitespace; any
+ ;; other whitespace at the beginning indicates a blockquote. The
+ ;; reason all of these rules are handled here, is so that
+ ;; blockquote detection doesn't interfere with indented list
+ ;; members.
+ ["^\\(\\s-*\\(-\\|[0-9]+\\.\\|\\(.+\\)[ \t]+::\n?\\)\\)?\\([ \t]+\\)" 4
+ emacs-wiki-markup-list-or-paragraph]
+
+ ;; "verse" text is indicated the same way as a quoted e-mail
+ ;; response: "> text", where text may contain initial whitespace
+ ;; (see below).
+ ["<p>\\s-+> \\(\\([^\n]\n?\\)+\\)\\(\\s-*</p>\\)?" 0
+ emacs-wiki-markup-verse]
+
+ ;; join together the parts of a list
+ ["</\\([oud]l\\)>\\s-*\\(</p>\\s-*<p>\\s-*\\)?<\\1>\\s-*" 0 ""]
+
+ ;; join together the parts of a table
+ (vector
+ (concat "</tbody>\\s-*"
+ "</table>\\s-*" "\\(</p>\\s-*<p>\\s-*\\)?" "<table[^>]*>\\s-*"
+ "<tbody>\\s-*") 0 "")
+ ["</table>\\s-*\\(</p>\\s-*<p>\\s-*\\)?<table[^>]*>\\s-*" 0 ""]
+
+ ;; fixup paragraph delimiters
+ (vector
+ (concat "<p>\\s-*\\(</?" emacs-wiki-block-groups-regexp ">\\)") 0 "\\1")
+ (vector (concat "\\(</?" emacs-wiki-block-groups-regexp
+ ">\\)\\s-*\\(</p>\\)") 3 "\\1")
+
+ ;; terminate open paragraph at the end of the buffer
+ ["<p>\\s-*\\'" 0 ""]
+ ;; make sure to close any open text (paragraphs)
+ ["\\([^> \t\n]\\)\\s-*\\'" 0 "\\1\n</p>"]
+ ;; lists have no whitespace after them, so add a final linebreak
+ ["\\(</[oud]l>\\)\\(\\s-*\\(<hr>\\|\\'\\)\\)" 0 "\\1\n<br>\\2"]
+
+ ;; replace WikiLinks in the buffer (links to other pages)
+ ;; <nop> before a WikiName guards it from being replaced
+ ;; '''' can be used to add suffixes, such as WikiName''''s
+ [emacs-wiki-url-or-name-regexp 0 emacs-wiki-markup-link]
+ ["''''" 0 ""]
+
+ ;; bare email addresses
+ (vector
+ (concat
+ "\\([^:.@/a-zA-Z0-9]\\)"
+ "\\([-a-zA-Z0-9._]+@\\([-a-zA-z0-9_]+\\.\\)+[a-zA-Z0-9]+\\)"
+ "\\([^\"a-zA-Z0-9]\\)")
+ 0
+ "\\1<a href=\"mailto:\\2\">\\2</a>\\4")
+
+ ;; replace quotes, since most browsers don't understand `` and ''
+ ["\\(``\\|''\\)" 0 "\""]
+
+ ;; insert the default publishing header
+ (function
+ (lambda ()
+ (insert emacs-wiki-publishing-header)))
+
+ ;; insert the default publishing footer
+ (function
+ (lambda ()
+ (goto-char (point-max))
+ (insert emacs-wiki-publishing-footer)))
+
+ ;; process any remaining markup tags
+ [emacs-wiki-tag-regexp 0 emacs-wiki-markup-custom-tags])
+ "List of markup rules to apply when publishing a Wiki page.
+Each member of the list is either a function, or a vector of the form:
+
+ [REGEXP/SYMBOL TEXT-BEGIN-GROUP REPLACEMENT-TEXT/FUNCTION/SYMBOL].
+
+REGEXP is a regular expression, or symbol whose value is a regular
+expression, which is searched for using `re-search-forward'.
+TEXT-BEGIN-GROUP is the matching group within that regexp which
+denotes the beginning of the actual text to be marked up.
+REPLACEMENT-TEXT is a string that will be passed to `replace-match'.
+If it is not a string, but a function, it will be called to determine
+what the replacement text should be (it must return a string). If it
+is a symbol, the value of that symbol should be a string.
+
+The replacements are done in order, one rule at a time. Writing the
+regular expressions can be a tricky business. Note that case is never
+ignored. `case-fold-search' is always be bound to nil while
+processing the markup rules.
+
+Here is a description of the default markup rules:
+
+Headings
+
+ * First level
+ ** Second level
+ *** Third level
+
+ Note that the first level is actually indicated using H2, so that
+ it doesn't appear at the same level as the page heading (which
+ conceptually titles the section of that Wiki page).
+
+Horizontal rules
+
+----
+
+Emphasis
+
+ *emphasis*
+ **strong emphasis**
+ ***very strong emphasis***
+ _underlined text_
+ =verbatim=
+
+ <verbatim>This tag should be used for larger blocks of
+ text</verbatim>.
+
+Footnotes
+
+ A reference[1], which is just a number in square brackets,
+ constitutes a footnote reference.
+
+ Footnotes:
+
+ [1] Footnotes are defined by the same number in brackets
+ occurring at the beginning of a line. Use footnote-mode's C-c
+ ! a command, to very easily insert footnotes while typing. Use
+ C-x C-x to return to the point of insertion.
+
+Paragraphs
+
+ One or more blank lines separates paragraphs.
+
+Centered paragraphs and quotations
+
+ A line that begins with six or more columns of whitespace (made up
+ of tabs or spaces) indicates a centered paragraph. I assume this
+ because it's expected you will use M-s to center the line, which
+ usually adds a lot of whitespace before it.
+
+ If a line begins with some whitespace, but less than six columns, it
+ indicates a quoted paragraph.
+
+Poetic verse
+
+ Poetry requires that whitespace be preserved, without resorting to
+ the monospace typical of <pre>. For this, the following special
+ markup exists, which is reminiscent of e-mail quotations:
+
+ > A line of Emacs verse;
+ > forgive its being so terse.
+
+ You can also use the <verse> tag, if you prefer:
+
+ <verse>
+ A line of Emacs verse;
+ forgive its being so terse.
+ </verse>
+
+Literal paragraphs
+
+ Use the HTML tags <pre></pre> to insert a paragraph and preserve
+ whitespace. If you're inserting a block of code, you will almost
+ always want to use <verbatim></verbatim> *within* the <pre> tags.
+ The shorcut for doing this is to use the <example> tag:
+
+ <example>
+ Some literal text or code here.
+ </example>
+
+Lists
+
+ - bullet list
+
+ 1. Enumerated list
+
+ Term :: A definition list
+
+ Blank lines between list elements are optional, but required between
+ members of a definition list.
+
+Tables
+
+ There are two forms of table markup supported. If Takaaki Ota's
+ table.el package is available, then simply create your tables using
+ his package, and they will be rendered into the appropriate HTML.
+
+ If table.el is not available, then only very simple table markup is
+ supported. The attributes of the table are kept in
+ `emacs-wiki-table-attributes'. The syntax is:
+
+ Double bars || Separate header fields
+ Single bars | Separate body fields
+ Here are more | body fields
+ Triple bars ||| Separate footer fields
+
+ Other paragraph markup applies to both styles, meaning that if six
+ or more columns of whitespace precedes the first line of the table,
+ it will be centered, and if any whitespace at all precedes first
+ line, it will occur in a blockquote.
+
+Anchors and tagged links
+
+ #example If you begin a line with \"#anchor\" -- where anchor
+ can be any word that doesn't contain whitespace -- it defines an
+ anchor at that point into the document. This anchor text is not
+ displayed.
+
+ You can reference an anchored point in another page (or even in the
+ current page) using WikiName#anchor. The #anchor will never be
+ displayed in HTML, whether at the point of definition or reference,
+ but it will cause browsers to jump to that point in the document.
+
+Redirecting to another page or URL
+
+ Sometimes you may wish to redirect someone to another page. To do
+ this, put:
+
+ <redirect url=\"http://somewhereelse.com\"/>
+
+ at the top of the page. If the <redirect> tag specifies content,
+ this will be used as the redirection message, rather than the
+ default.
+
+ The numbers of seconds to delay is defined by
+ `emacs-wiki-redirect-delay', which defaults to 2 seconds. The page
+ shown will also contain a link to click on, for browsing which do
+ not support automatic refreshing.
+
+URLs
+
+ A regular URL is given as a link. If it's an image URL, it will
+ be inlined using an IMG tag.
+
+Embedded lisp
+
+ <lisp>(concat \"This form gets\" \"inserted\")</lisp>
+
+Special handling of WikiNames
+
+ If you need to add a plural at the end of a WikiName, separate it
+ with four single quotes: WikiName''''s.
+
+ To prevent a link name (of any type) from being treated as such,
+ surround it with =equals= (to display it in monotype), or prefix it
+ with the tag <nop>.
+
+Special Wiki links
+
+ Besides the normal WikiName type links, emacs-wiki also supports
+ extended links:
+
+ [[link text][optional link description]]
+
+ An extended link is always a link, no matter how it looks. This
+ means you can use any file in your `emacs-wiki-directories' as a
+ Wiki file. If you provide an optional description, that's what will
+ be shown instead of the link text. This is very useful for
+ providing textual description of URLs.
+
+ See the documentation to emacs-wiki-image-regexp for how to inline
+ files and images.
+
+InterWiki names
+
+ There are times when you will want to constantly reference pages on
+ another website. Rather than repeating the URL ad nauseum, you can
+ define an InterWiki name. This is a set of WikiNames to URL
+ correlations, that support textual substitution using #anchor names
+ (which are appended to the URL). For example, MeatballWiki is
+ defined in the variable `emacs-wiki-interwiki-names'. It means you
+ can reference the page \"MeatBall\" on MeatballWiki using this
+ syntax:
+
+ MeatballWiki#MeatBall
+
+ In the resulting HTML, the link is simply shown as
+ \"MeatballWiki:MeatBall\"."
+ :type '(repeat
+ (choice
+ (vector :tag "Markup rule"
+ (choice regexp symbol)
+ integer
+ (choice string function symbol))
+ function))
+ :group 'emacs-wiki-publish)
+
+(defcustom emacs-wiki-changelog-markup
+ (list
+ ;; process any custom markup tags
+ [emacs-wiki-tag-regexp 0 emacs-wiki-markup-custom-tags]
+
+ ["&" 0 "&"]
+ ["<" 0 "<"]
+ [">" 0 ">"]
+
+ ["^\\(\\S-+\\)\\s-+\\(.+\\)" 0 emacs-wiki-markup-changelog-section]
+
+ ;; emphasized or literal text
+ ["\\(^\\|[-[ \t\n<('`\"]\\)\\(=[^= \t\n]\\|_[^_ \t\n]\\|\\*+[^* \t\n]\\)"
+ 2 emacs-wiki-markup-word]
+
+ ;; headings, outline-mode style
+ ["^\\*\\s-+\\(.+\\)$" 0 "<h2>\\1</h2>"]
+
+ ;; escape the 'file' entries, incase they are extended wiki links
+ ["^[ \t]+\\* \\([^:(]+\\)\\([ \t]+(\\|:\\)" 0 emacs-wiki-changelog-escape-files]
+
+ ;; don't require newlines between unnumbered lists.
+ ["^\\s-*\\(\\*\\)" 1 "\n\\1"]
+
+ ;; the beginning of the buffer begins the first paragraph
+ ["\\`\n*" 0 "<p>\n"]
+ ;; plain paragraph separator
+ ["\n\\([ \t]*\n\\)+" 0 "\n\n</p>\n\n<p>\n"]
+
+ ;; unnumbered List items begin with a -. numbered list items
+ ;; begin with number and a period. definition lists have a
+ ;; leading term separated from the body with ::. centered
+ ;; paragraphs begin with at least six columns of whitespace; any
+ ;; other whitespace at the beginning indicates a blockquote. The
+ ;; reason all of these rules are handled here, is so that
+ ;; blockquote detection doesn't interfere with indented list
+ ;; members.
+ ["^\\(\\s-*\\(\\*\\)\\)?\\([ \t]+\\)\\(\\([^\n]\n?\\)+\\)" 3
+ "<ul>\n<li>\\4</ul>\n"]
+
+ ;; join together the parts of a list
+ ["</\\([oud]l\\)>\\s-*\\(</p>\\s-*<p>\\s-*\\)?<\\1>\\s-*" 0 ""]
+
+ ;; fixup paragraph delimiters
+ (vector
+ (concat "<p>\\s-*\\(</?" emacs-wiki-block-groups-regexp ">\\)") 0 "\\1")
+ (vector (concat "\\(</?" emacs-wiki-block-groups-regexp
+ ">\\)\\s-*\\(</p>\\)") 3 "\\1")
+
+ ;; terminate open paragraph at the end of the buffer
+ ["<p>\\s-*\\'" 0 ""]
+ ;; make sure to close any open text (paragraphs)
+ ["\\([^> \t\n]\\)\\s-*\\'" 0 "\\1\n</p>"]
+ ;; lists have no whitespace after them, so add a final linebreak
+ ["\\(</[oud]l>\\)\\(\\s-*\\(<hr>\\|\\'\\)\\)" 0 "\\1\n<br>\\2"]
+
+ ;; bare email addresses
+ (vector
+ (concat
+ "\\([^:.@/a-zA-Z0-9]\\)"
+ "\\([-a-zA-Z0-9._]+@\\([-a-zA-z0-9_]+\\.\\)+[a-zA-Z0-9]+\\)"
+ "\\([^\"a-zA-Z0-9]\\)")
+ 0
+ "\\1<a href=\"mailto:\\2\">\\2</a>\\4")
+
+ ;; replace WikiLinks in the buffer (links to other pages)
+ [emacs-wiki-url-or-name-regexp 0 emacs-wiki-markup-link]
+ ["''''" 0 ""]
+
+ ;; insert the default publishing header
+ (function
+ (lambda ()
+ (insert emacs-wiki-publishing-header)))
+
+ ;; insert the default publishing footer
+ (function
+ (lambda ()
+ (goto-char (point-max))
+ (insert emacs-wiki-publishing-footer))))
+ "List of markup rules for publishing ChangeLog files.
+These are used when the wiki page's name is ChangeLog."
+ :type '(repeat
+ (choice
+ (vector :tag "Markup rule"
+ (choice regexp symbol)
+ integer
+ (choice string function symbol))
+ function))
+ :group 'emacs-wiki-publish)
+
+(defun emacs-wiki-transform-content-type (content-type)
+ "Using `emacs-wiki-coding-map', try and resolve an emacs coding
+ system to an associated HTML coding system. If no match is found,
+ `emacs-wiki-charset-default' is used instead."
+ (let ((match (assoc (coding-system-base content-type)
+ emacs-wiki-coding-map)))
+ (if match
+ (cadr match)
+ emacs-wiki-charset-default)))
+
+(defun emacs-wiki-private-p (name)
+ "Return non-nil if NAME is a private page, and shouldn't be published."
+ (if name
+ (if emacs-wiki-use-mode-flags
+ (let* ((page-file (emacs-wiki-page-file name t))
+ (filename (and page-file (file-truename page-file))))
+ (if filename
+ (or (eq ?- (aref (nth 8 (file-attributes
+ (file-name-directory filename))) 7))
+ (eq ?- (aref (nth 8 (file-attributes filename)) 7)))))
+ (let ((private-pages emacs-wiki-private-pages) private)
+ (while private-pages
+ (if (string-match (car private-pages) name)
+ (setq private t private-pages nil)
+ (setq private-pages (cdr private-pages))))
+ private))))
+
+(defun emacs-wiki-editable-p (name)
+ "Return non-nil if NAME is a page that may be publically edited.
+If the page does not exist, the page will be created if: mode flags
+are not being checked, and it is a page listed in
+`emacs-wiki-editable-pages', or the first directory in
+`emacs-wiki-directories' is writable. In either case, the new page
+will be created in the first directory in `emacs-wiki-directories'."
+ (if (and name emacs-wiki-http-support-editing)
+ (if emacs-wiki-use-mode-flags
+ (let ((filename
+ (file-truename
+ (or (emacs-wiki-page-file name t)
+ (expand-file-name name (car emacs-wiki-directories))))))
+ (if (file-exists-p filename)
+ (eq ?w (aref (nth 8 (file-attributes filename)) 8))
+ (eq ?w (aref (nth 8 (file-attributes
+ (file-name-directory filename))) 8))))
+ (let ((editable-pages emacs-wiki-editable-pages) editable)
+ (while editable-pages
+ (if (string-match (car editable-pages) name)
+ (setq editable t editable-pages nil)
+ (setq editable-pages (cdr editable-pages))))
+ editable))))
+
+(defun emacs-wiki-visit-published-file (&optional arg)
+ "Visit the current wiki page's published result."
+ (interactive "P")
+ (if arg
+ (find-file-other-window (emacs-wiki-published-file))
+ (funcall emacs-wiki-browse-url-function
+ (concat "file:" (emacs-wiki-published-file)))))
+
+(defun emacs-wiki-dired-publish ()
+ "Publish all marked files in a dired buffer."
+ (interactive)
+ (emacs-wiki-publish-files (dired-get-marked-files) t))
+
+(defun emacs-wiki-prettify-title (title)
+ "Prettify the given TITLE."
+ (save-match-data
+ (let ((case-fold-search nil))
+ (while (string-match "\\([A-Za-z]\\)\\([A-Z0-9]\\)" title)
+ (setq title (replace-match "\\1 \\2" t nil title)))
+ (let* ((words (split-string title))
+ (w (cdr words)))
+ (while w
+ (if (member (downcase (car w))
+ emacs-wiki-downcase-title-words)
+ (setcar w (downcase (car w))))
+ (setq w (cdr w)))
+ (mapconcat 'identity words " ")))))
+
+(defun emacs-wiki-publish (&optional arg)
+ "Publish all wikis that need publishing.
+If the published wiki already exists, it is only overwritten if the
+wiki is newer than the published copy. When given the optional
+argument ARG, all wikis are rewritten, no matter how recent they are.
+The index file is rewritten no matter what."
+ (interactive "P")
+ ;; prompt to save any emacs-wiki buffers
+ (save-some-buffers nil (lambda ()
+ (eq major-mode 'emacs-wiki-mode)))
+ ;; ensure the publishing location is available
+ (unless (file-exists-p emacs-wiki-publishing-directory)
+ (message "Creating publishing directory %s"
+ emacs-wiki-publishing-directory)
+ (make-directory emacs-wiki-publishing-directory))
+ (if (emacs-wiki-publish-files
+ (let* ((names (emacs-wiki-file-alist))
+ (files (list t))
+ (lfiles files))
+ (while names
+ (setcdr lfiles (cons (cdar names) nil))
+ (setq lfiles (cdr lfiles)
+ names (cdr names)))
+ (cdr files)) arg)
+ ;; republish the index if any pages were published
+ (with-current-buffer (emacs-wiki-generate-index t t)
+ (emacs-wiki-replace-markup emacs-wiki-index-page)
+ (let ((backup-inhibited t))
+ (write-file (emacs-wiki-published-file emacs-wiki-index-page)))
+ (kill-buffer (current-buffer))
+ (message "All Wiki pages%s have been published."
+ (if emacs-wiki-current-project
+ (concat " for project " emacs-wiki-current-project)
+ "")))
+ (message "No Wiki pages%s need publishing at this time."
+ (if emacs-wiki-current-project
+ (concat " in project " emacs-wiki-current-project)
+ ""))))
+
+(defun emacs-wiki-publish-this-page ()
+ "Force publication of the current page."
+ (interactive)
+ (emacs-wiki-publish-files (list buffer-file-name) t))
+
+(defun emacs-wiki-publish-files (files force)
+ "Publish all files in list FILES.
+If the argument FORCE is nil, each file is only published if it is
+newer than the published version. If the argument FORCE is non-nil,
+the file is published no matter what."
+ (let (published-some file page published)
+ (while files
+ (setq file (car files)
+ files (cdr files)
+ page (emacs-wiki-page-name file)
+ published (emacs-wiki-published-file page))
+ (if (and (not (emacs-wiki-private-p page))
+ (or force (file-newer-than-file-p file published)))
+ (with-temp-buffer
+ (insert-file-contents file t)
+ (cd (file-name-directory file))
+ (emacs-wiki-maybe)
+ (emacs-wiki-replace-markup)
+ (let ((backup-inhibited t)
+ (buffer-file-coding-system
+ (when (boundp 'buffer-file-coding-system)
+ buffer-file-coding-system)))
+ (when (eq buffer-file-coding-system 'undecided-unix)
+ ;; make it agree with the default charset
+ (setq buffer-file-coding-system
+ emacs-wiki-coding-default))
+ (write-file published))
+ (setq published-some t))))
+ published-some))
+
+
+
+(defun emacs-wiki-escape-html-specials (&optional end)
+ (while (and (or (< (point) end) (not end))
+ (re-search-forward "[<>&\"]" end t))
+ (cond
+ ((eq (char-before) ?\")
+ (delete-char -1)
+ (insert """))
+ ((eq (char-before) ?\<)
+ (delete-char -1)
+ (insert "<"))
+ ((eq (char-before) ?\>)
+ (delete-char -1)
+ (insert ">"))
+ ((eq (char-before) ?\&)
+ (delete-char -1)
+ (insert "&")))))
+
+;; we currently only do this on links. this means a stray '&' in an
+;; emacs-wiki document risks being misinterpreted when being published, but
+;; this is the price we pay to be able to inline HTML content without special
+;; tags.
+(defun emacs-wiki-escape-html-string (str)
+ "Convert to character entities any non alphanumeric characters outside of a
+ few punctuation symbols, that risk being misinterpreted if not escaped"
+ (when str
+ (let (pos code len)
+ (save-match-data
+ (while (setq pos (string-match "[^-[:alnum:]/:._=@\\?~#]" str pos))
+ (setq code (int-to-string (aref str pos))
+ len (length code)
+ str (replace-match (concat "&#" code ";") nil nil str)
+ pos (+ 3 len pos)))
+ str))))
+
+(defun emacs-wiki-replace-markup (&optional title)
+ "Replace markup according to `emacs-wiki-publishing-markup'."
+ (let* ((emacs-wiki-meta-http-equiv emacs-wiki-meta-http-equiv)
+ (emacs-wiki-current-page-title title)
+ (emacs-wiki-publishing-p t)
+ (case-fold-search nil)
+ (inhibit-read-only t)
+ (rules (if (string= (emacs-wiki-page-name) "ChangeLog")
+ emacs-wiki-changelog-markup
+ emacs-wiki-publishing-markup))
+ (limit (* (length rules) (point-max)))
+ (verbose (and emacs-wiki-report-threshhold
+ (> (point-max) emacs-wiki-report-threshhold)))
+ (base 0)
+ (emacs-wiki-meta-content
+ (concat emacs-wiki-meta-content-type "; charset="
+ (if (stringp emacs-wiki-meta-content-coding)
+ emacs-wiki-meta-content-coding
+ (emacs-wiki-transform-content-type
+ (or buffer-file-coding-system
+ emacs-wiki-coding-default))))))
+ (run-hooks 'emacs-wiki-before-markup-hook)
+ (while rules
+ (goto-char (point-min))
+ (if (functionp (car rules))
+ (funcall (car rules))
+ (let ((regexp (aref (car rules) 0))
+ (group (aref (car rules) 1))
+ (replacement (aref (car rules) 2))
+ start last-pos pos)
+ (if (symbolp regexp)
+ (setq regexp (symbol-value regexp)))
+ (if verbose
+ (message "Publishing %s...%d%%"
+ (emacs-wiki-page-name)
+ (* (/ (float (+ (point) base)) limit) 100)))
+ (while (and regexp (setq pos (re-search-forward regexp nil t)))
+ (if verbose
+ (message "Publishing %s...%d%%"
+ (emacs-wiki-page-name)
+ (* (/ (float (+ (point) base)) limit) 100)))
+ (unless (get-text-property (match-beginning group) 'read-only)
+ (let ((text (cond
+ ((functionp replacement)
+ (funcall replacement))
+ ((symbolp replacement)
+ (symbol-value replacement))
+ (t replacement))))
+ (when text
+ (condition-case nil
+ (replace-match text t)
+ (error
+ (replace-match "[FIXME: invalid characters]" t))))))
+ (if (and last-pos (= pos last-pos))
+ (if (eobp)
+ (setq regexp nil)
+ (forward-char 1)))
+ (setq last-pos pos))))
+ (setq rules (cdr rules)
+ base (+ base (point-max))))
+ (run-hooks 'emacs-wiki-after-markup-hook)
+ (if verbose
+ (message "Publishing %s...done" (emacs-wiki-page-name)))))
+
+(defun emacs-wiki-custom-tags (&optional highlight-p)
+ (let ((tag-info (or (assoc (match-string 1) emacs-wiki-markup-tags)
+ (assoc (match-string 1) emacs-wiki-dangerous-tags))))
+ (when (and tag-info (or (not highlight-p)
+ (nth 3 tag-info)))
+ (let ((closed-tag (match-string 3))
+ (start (match-beginning 0))
+ (beg (point)) end attrs)
+ (when (nth 2 tag-info)
+ (let ((attrstr (match-string 2)))
+ (while (and attrstr
+ (string-match
+ "\\([^ \t\n=]+\\)\\(=\"\\([^\"]+\\)\"\\)?" attrstr))
+ (let ((attr (cons (downcase
+ (match-string-no-properties 1 attrstr))
+ (match-string-no-properties 3 attrstr))))
+ (setq attrstr (replace-match "" t t attrstr))
+ (if attrs
+ (nconc attrs (list attr))
+ (setq attrs (list attr)))))))
+ (if (and (cadr tag-info) (not closed-tag))
+ (if (search-forward (concat "</" (car tag-info) ">") nil t)
+ (unless highlight-p
+ (delete-region (match-beginning 0) (point)))
+ (setq tag-info nil)))
+ (when tag-info
+ (setq end (point-marker))
+ (unless highlight-p
+ (delete-region start beg))
+ (goto-char (if highlight-p beg start))
+ (let ((args (list start end)))
+ (if (nth 2 tag-info)
+ (nconc args (list attrs)))
+ (if (nth 3 tag-info)
+ (nconc args (list highlight-p)))
+ (apply (nth 4 tag-info) args))))))
+ nil)
+
+(defun emacs-wiki-markup-initial-directives ()
+ (cond
+ ((string= (match-string 1) "title")
+ (set (make-local-variable 'emacs-wiki-current-page-title) (match-string 2)))
+ (t ;; "style"
+ (set (make-local-variable 'emacs-wiki-style-sheet)
+ (concat "<link rel=\"stylesheet\" type=\"text/css\" href=\""
+ (match-string 2) "\">"))))
+ "")
+
+(defalias 'emacs-wiki-markup-custom-tags 'emacs-wiki-custom-tags)
+
+(defun emacs-wiki-highlight-title ()
+ (add-text-properties (+ 7 (match-beginning 0))
+ (line-end-position)
+ '(face emacs-wiki-header-1)))
+
+(defun emacs-wiki-highlight-custom-tags ()
+ ;; Remove the match-data related to the url-or-name-regexp, which is
+ ;; part of emacs-wiki-highlight-regexp. All in the name of speed.
+ (let ((match-data (match-data)))
+ (setcdr (cdr match-data)
+ (nthcdr (* 2 (+ 2 emacs-wiki-url-or-name-regexp-group-count))
+ match-data))
+ (set-match-data match-data)
+ (emacs-wiki-custom-tags t)))
+
+(defun emacs-wiki-example-tag (beg end highlight-p)
+ (if highlight-p
+ (progn
+ (emacs-wiki-multiline-maybe beg end)
+ (goto-char end))
+ (insert "<pre class=\"example\">")
+ (emacs-wiki-escape-html-specials end)
+ (when (< (point) end)
+ (goto-char end))
+ (insert "</pre>")
+ (add-text-properties beg (point) '(rear-nonsticky (read-only)
+ read-only t))))
+
+(defun emacs-wiki-verbatim-tag (beg end highlight-p)
+ (if highlight-p
+ (progn
+ (emacs-wiki-multiline-maybe beg end)
+ (goto-char end))
+ (emacs-wiki-escape-html-specials end)
+ (add-text-properties beg end '(rear-nonsticky (read-only)
+ read-only t))))
+
+(defun emacs-wiki-nowiki-tag (beg end highlight-p)
+ (if highlight-p
+ (goto-char end)
+ (add-text-properties
+ beg end '(read-nonsticky (read-only) read-only t))))
+
+(defun emacs-wiki-verse-tag (beg end)
+ (save-excursion
+ (while (< (point) end)
+ (unless (eq (char-after) ?\n)
+ (insert "> "))
+ (forward-line))))
+
+(defvar emacs-wiki-numbered-counter 1)
+(make-variable-buffer-local 'emacs-wiki-numbered-counter)
+
+(defun emacs-wiki-numbered-tag (beg end)
+ (save-excursion
+ (goto-char beg)
+ (setq end (copy-marker (1- end)))
+ (insert "<table cellspacing=\"8\">")
+ (insert (format "<tr><td valign=\"top\"><strong>%d</strong></td>
+<td><p><a name=\"%d\"/>" emacs-wiki-numbered-counter
+ emacs-wiki-numbered-counter))
+ (setq emacs-wiki-numbered-counter
+ (1+ emacs-wiki-numbered-counter))
+ (while (and (< (point) end)
+ (re-search-forward "^$" end t))
+ (replace-match (format "</p>
+</td>
+</tr><tr><td valign=\"top\"><strong>%d</strong></td><td>
+<p><a name=\"%d\"/>" emacs-wiki-numbered-counter
+ emacs-wiki-numbered-counter))
+ (setq emacs-wiki-numbered-counter
+ (1+ emacs-wiki-numbered-counter)))
+ (goto-char end)
+ (insert (format "</p>
+</td></tr></table>" (1+ emacs-wiki-numbered-counter)))))
+
+(defun emacs-wiki-redirect-tag (beg end attrs)
+ (let ((link (cdr (assoc "url" attrs))))
+ (when link
+ (setq emacs-wiki-meta-http-equiv "Refresh"
+ emacs-wiki-meta-content
+ (concat (or (cdr (assoc "delay" attrs))
+ (int-to-string emacs-wiki-redirect-delay))
+ ";\nURL=" (emacs-wiki-link-url link)))
+ (if (= beg end)
+ (insert "You should momentarily be redirected to [[" link "]].")
+ (goto-char end))
+ (delete-region (point) (point-max)))))
+
+(defun emacs-wiki-nop-tag (beg end highlight-p)
+ (if highlight-p
+ (add-text-properties beg (point) '(invisible t intangible t)))
+ (when (looking-at emacs-wiki-name-regexp)
+ (goto-char (match-end 0))
+ (unless highlight-p
+ (add-text-properties beg (point)
+ '(rear-nonsticky (read-only) read-only t)))))
+
+(defun emacs-wiki-insert-anchor (anchor)
+ "Insert an anchor, either around the word at point, or within a tag."
+ (skip-chars-forward " \t\n")
+ (if (looking-at "<\\([^ />]+\\)>")
+ (let ((tag (match-string 1)))
+ (goto-char (match-end 0))
+ (insert "<a name=\"" anchor "\" id=\"" anchor "\">")
+ (when emacs-wiki-anchor-on-word
+ (or (and (search-forward (format "</%s>" tag)
+ (line-end-position) t)
+ (goto-char (match-beginning 0)))
+ (forward-word 1)))
+ (insert "</a>"))
+ (insert "<a name=\"" anchor "\" id=\"" anchor "\">")
+ (when emacs-wiki-anchor-on-word
+ (forward-word 1))
+ (insert "</a>")))
+
+(defun emacs-wiki-contents-tag (beg end attrs)
+ (let ((max-depth (let ((depth (cdr (assoc "depth" attrs))))
+ (or (and depth (string-to-int depth)) 2)))
+ (index 1)
+ base contents l)
+ (save-excursion
+ (catch 'done
+ (while (re-search-forward "^\\(\\*+\\)\\s-+\\(.+\\)" nil t)
+ (setq l (length (match-string 1)))
+ (if (null base)
+ (setq base l)
+ (if (< l base)
+ (throw 'done t)))
+ (when (<= l max-depth)
+ (setq contents (cons (cons l (match-string-no-properties 2))
+ contents))
+ (goto-char (match-beginning 2))
+ (emacs-wiki-insert-anchor (concat "sec" (int-to-string index)))
+ (setq index (1+ index))))))
+ (setq index 1 contents (reverse contents))
+ (let ((depth 1) (sub-open 0) (p (point)))
+ (insert "<dl class=\"contents\">\n")
+ (while contents
+ (insert "<dt class=\"contents\">\n")
+ (insert "<a href=\"#sec" (int-to-string index) "\">"
+ (cdar contents)
+ "</a>\n")
+ (setq index (1+ index))
+ (insert "</dt>\n")
+ (setq depth (caar contents)
+ contents (cdr contents))
+ (if contents
+ (cond
+ ((< (caar contents) depth)
+ (let ((idx (caar contents)))
+ (while (< idx depth)
+ (insert "</dl>\n</dd>\n")
+ (setq sub-open (1- sub-open)
+ idx (1+ idx)))))
+ ((> (caar contents) depth) ; can't jump more than one ahead
+ (insert "<dd>\n<dl class=\"contents\">\n")
+ (setq sub-open (1+ sub-open))))))
+ (while (> sub-open 0)
+ (insert "</dl>\n</dd>\n")
+ (setq sub-open (1- sub-open)))
+ (insert "</dl>\n")
+ (put-text-property p (point) 'read-only t))))
+
+(defun emacs-wiki-lisp-tag (beg end highlight-p)
+ (if highlight-p
+ (add-text-properties
+ beg end
+ (list 'font-lock-multiline t
+ 'display (emacs-wiki-eval-lisp
+ (buffer-substring-no-properties (+ beg 6) (- end 7)))
+ 'intangible t))
+ (save-excursion
+ (insert (emacs-wiki-eval-lisp
+ (prog1
+ (buffer-substring-no-properties beg end)
+ (delete-region beg end)))))))
+
+(defcustom emacs-wiki-command-default-file nil
+ "If non-nil, this default program to use with <command> tags.
+If nil, Eshell is used, since it works on all platforms."
+ :type '(choice file (const :tag "Use Eshell" nil))
+ :group 'emacs-wiki-publish)
+
+(defun emacs-wiki-command-tag (beg end attrs &optional highlight-p pre-tags)
+ (if highlight-p
+ (goto-char end)
+ (while (looking-at "\\s-*$")
+ (forward-line))
+ (let ((interp (or (cdr (assoc "file" attrs))
+ emacs-wiki-command-default-file)))
+ (if (null interp)
+ (eshell-command (prog1
+ (buffer-substring-no-properties (point) end)
+ (delete-region beg end)) t)
+ (let ((file (make-temp-file "ewiki")))
+ (unwind-protect
+ (let ((args (split-string interp)))
+ (write-region (point) end file)
+ (delete-region beg end)
+ (if pre-tags
+ (insert "<pre>\n"))
+ (apply 'call-process (car args) file t nil (cdr args))
+ (while (eq (char-syntax (char-before)) ? )
+ (backward-char))
+ (add-text-properties beg (point)
+ '(rear-nonsticky (read-only)
+ read-only t))
+ (if pre-tags
+ (insert "</pre>\n")))
+ (if (file-exists-p file)
+ (delete-file file))))))))
+
+(defcustom emacs-wiki-c-to-html
+ (if (or (featurep 'executable)
+ (load "executable" t t))
+ (concat (executable-find "c2html") " -c -s"))
+ "Program to use to convert <c-source> tag text to HTML."
+ :type 'string
+ :group 'emacs-wiki-publish)
+
+(defun emacs-wiki-c-source-tag (beg end attrs highlight-p)
+ (if highlight-p
+ (goto-char end)
+ (if emacs-wiki-c-to-html
+ (let ((c-to-html emacs-wiki-c-to-html))
+ (if (assoc "numbered" attrs)
+ (setq c-to-html (concat c-to-html " -n")))
+ (emacs-wiki-command-tag beg end (list (cons "file" c-to-html))))
+ (insert "<pre>")
+ (emacs-wiki-escape-html-specials end)
+ (goto-char end)
+ (add-text-properties beg (point)
+ '(rear-nonsticky (read-only) read-only t))
+ (insert "</pre>"))))
+
+(defun emacs-wiki-python-tag (beg end attrs highlight-p)
+ (emacs-wiki-command-tag
+ beg end (list (cons "file" (executable-find "python"))) highlight-p t))
+
+(defun emacs-wiki-perl-tag (beg end attrs highlight-p)
+ (emacs-wiki-command-tag
+ beg end (list (cons "file" (executable-find "perl"))) highlight-p t))
+
+(defun emacs-wiki-insert-xbel-bookmarks (bmarks folder)
+ "Insert a set of XBEL bookmarks as an HTML list."
+ (while bmarks
+ (let ((bookmark (car bmarks)))
+ (cond
+ ((equal (xml-tag-name bookmark) "folder")
+ (let ((title (cadr (xml-tag-child bookmark "title"))))
+ (unless folder
+ (insert "<li>" title "\n<ul>\n"))
+ (emacs-wiki-insert-xbel-bookmarks (xml-tag-children bookmark)
+ (if (equal folder title)
+ nil
+ folder))
+ (unless folder
+ (insert "</ul>\n"))))
+ ((equal (xml-tag-name bookmark) "bookmark")
+ (unless folder
+ (insert "<li><a href=\"" (xml-tag-attr bookmark "href") "\">"
+ (cadr (xml-tag-child bookmark "title")) "</a>\n")))))
+ (setq bmarks (cdr bmarks))))
+
+(defcustom emacs-wiki-xbel-bin-directory "/usr/bin"
+ "Directory where the xbel parsing utilities reside."
+ :type 'directory
+ :group 'emacs-wiki-publish)
+
+(defun emacs-wiki-bookmarks-tag (beg end attrs)
+ (require 'xml-parse)
+ (let ((filename (expand-file-name (cdr (assoc "file" attrs))))
+ (type (cdr (assoc "type" attrs)))
+ (folder (cdr (assoc "folder" attrs)))
+ (this-buffer (current-buffer))
+ buffer)
+ (when filename
+ (cond
+ (type
+ (setq buffer (get-buffer-create " *xbel_parse*"))
+ (with-current-buffer buffer
+ (erase-buffer)
+ (call-process
+ (format "%s/%s_parse"
+ (directory-file-name emacs-wiki-xbel-bin-directory) type)
+ nil t nil filename)))
+ (t
+ (setq buffer (find-file-noselect filename))))
+ (insert "<ul>\n")
+ (emacs-wiki-insert-xbel-bookmarks
+ (with-current-buffer buffer
+ (goto-char (point-min))
+ (when (re-search-forward "<!DOCTYPE\\s-+xbel" nil t) ; XBEL format
+ (goto-char (match-beginning 0))
+ ;; the `cdr' is to skip the "title" child
+ (cdr (xml-tag-children (read-xml))))) folder)
+ (insert "</ul>\n")
+ (kill-buffer buffer)))
+ (while (eq (char-syntax (char-before)) ? )
+ (backward-char))
+ (add-text-properties beg (point)
+ '(rear-nonsticky (read-only) read-only t)))
+
+(defun emacs-wiki-link-url (wiki-link)
+ "Resolve the given WIKI-LINK into its ultimate URL form."
+ (let ((link (emacs-wiki-wiki-link-target wiki-link)))
+ (save-match-data
+ (if (or (emacs-wiki-wiki-url-p link)
+ (string-match emacs-wiki-image-regexp link)
+ (string-match emacs-wiki-file-regexp link))
+ link
+ (if (assoc (emacs-wiki-wiki-base link)
+ (emacs-wiki-file-alist t))
+ (if (string-match "#" link)
+ (concat (emacs-wiki-published-name
+ (substring link 0 (match-beginning 0))
+ (emacs-wiki-page-name)) "#"
+ (substring link (match-end 0)))
+ (emacs-wiki-published-name link (emacs-wiki-page-name))))))))
+
+(defsubst emacs-wiki-link-href (url name)
+ "Return an href string for URL and NAME."
+ (concat "<a href=\"" (emacs-wiki-published-name url) "\">" name "</a>"))
+
+(defun emacs-wiki-markup-link ()
+ "Resolve the matched wiki-link into its ultimate <a href> form.
+Images used the <img> tag."
+ ;; avoid marking up urls that appear to be inside existing HTML
+ (when (and (not (eq (char-after (point)) ?\"))
+ (not (eq (char-after (point)) ?\>)))
+ (let* ((wiki-link (match-string 0))
+ (url (emacs-wiki-escape-html-string
+ (emacs-wiki-link-url wiki-link)))
+ (name (emacs-wiki-escape-html-string
+ (emacs-wiki-wiki-visible-name wiki-link))))
+ (if (null url)
+ (if (and emacs-wiki-serving-p
+ (emacs-wiki-editable-p (emacs-wiki-wiki-base wiki-link)))
+ (concat "<a class=\"nonexistent\" href=\"editwiki?"
+ (emacs-wiki-wiki-base wiki-link) "\">" name "</a>")
+ (concat "<a class=\"nonexistent\" href=\""
+ emacs-wiki-maintainer "\">" name "</a>"))
+ (if (save-match-data
+ (string-match emacs-wiki-image-regexp url))
+ (concat "<img src=\"" url "\" alt=\"" name "\">")
+ (concat "<a href=\"" url "\">" name "</a>"))))))
+
+(defun emacs-wiki-markup-word ()
+ (let* ((beg (match-beginning 2))
+ (end (1- (match-end 2)))
+ (leader (buffer-substring-no-properties beg end))
+ open-tag close-tag mark-read-only loc multi-line)
+ (cond
+ ((string= leader "_")
+ (setq open-tag "<u>" close-tag "</u>"))
+ ((string= leader "=")
+ (setq open-tag "<code>" close-tag "</code>")
+ (setq mark-read-only t))
+ (t
+ (setq multi-line t)
+ (let ((l (length leader)))
+ (cond
+ ((= l 1) (setq open-tag "<em>" close-tag "</em>"))
+ ((= l 2) (setq open-tag "<strong>" close-tag "</strong>"))
+ ((= l 3) (setq open-tag "<strong><em>"
+ close-tag "</em></strong>"))))))
+ (if (and (setq loc (search-forward leader nil t))
+ (eq 0 (skip-syntax-forward "w" (1+ loc)))
+ (or multi-line (= 1 (count-lines beg loc))))
+ (progn
+ (replace-match "")
+ (insert close-tag)
+ (save-excursion
+ (goto-char beg)
+ (delete-region beg end)
+ (insert open-tag))
+ (if mark-read-only
+ (add-text-properties beg (point)
+ '(rear-nonsticky (read-only) read-only
+ t))))
+ (backward-char))
+ nil))
+
+(defun emacs-wiki-markup-anchor ()
+ (save-match-data
+ (emacs-wiki-insert-anchor (match-string 1)))
+ "")
+
+(defcustom emacs-wiki-entity-table
+ '(("#7779" . "s")
+ ("#7717" . "h")
+ ("#7789" . "t")
+ ("#7716" . "H")
+ ("#7826" . "Z"))
+ "Substitutions to use for HTML entities which are not fully
+supported by all browsers -- in other words, we are pre-empting the
+entity mechanism and providing our own textual equivalent. For
+Unicode browsers, this is usually unnecessary."
+ :type 'sexp
+ :group 'emacs-wiki)
+
+(defun emacs-wiki-markup-entity ()
+ (or (cdr (assoc (match-string 1)
+ emacs-wiki-entity-table))
+ (concat "&" (match-string 1) ";")))
+
+(defsubst emacs-wiki-surround-text (beg-tag end-tag move-func)
+ (insert beg-tag)
+ (funcall move-func)
+ (insert end-tag)) ; returns nil for us
+
+(defun emacs-wiki-markup-heading ()
+ (let ((len (1+ (length (match-string 1)))))
+ (emacs-wiki-surround-text (format "<h%d>" len) (format "</h%d>" len)
+ 'end-of-line)
+ ""))
+
+(defun emacs-wiki-markup-footnote ()
+ (if (/= (line-beginning-position) (match-beginning 0))
+ "<sup><a name=\"fnr.\\1\" href=\"#fn.\\1\">\\1</a></sup>"
+ (prog1
+ "<sup>[<a name=\"fn.\\1\" href=\"#fnr.\\1\">\\1</a>]</sup>"
+ (save-excursion
+ (save-match-data
+ (let* ((beg (goto-char (match-end 0)))
+ (end (and (search-forward "\n\n" nil t)
+ (prog1
+ (copy-marker (match-beginning 0))
+ (goto-char beg)))))
+ (while (re-search-forward "^[ \t]+\\([^\n]\\)" end t)
+ (replace-match "\\1" t))))))))
+
+(defsubst emacs-wiki-forward-paragraph ()
+ (and (re-search-forward "^\\s-*$" nil t)
+ (match-beginning 0)))
+
+(defun emacs-wiki-markup-list-or-paragraph ()
+ "Markup a list entry or quoted paragraph.
+The reason this function is so funky, is to prevent text properties
+like read-only from being inadvertently deleted."
+ (if (null (match-string 2))
+ (let* ((ws (match-string 4))
+ (tag (if (>= (string-width ws) 6)
+ "center"
+ "blockquote")))
+ (unless (and (equal tag "blockquote")
+ (save-excursion
+ (forward-line)
+ (or (eolp)
+ (looking-at "\\S-"))))
+ (emacs-wiki-surround-text (format "<%s>\n<p>\n%s" tag ws)
+ (format "\n</p>\n</%s>\n" tag)
+ 'emacs-wiki-forward-paragraph)))
+ (let ((str (match-string 2)))
+ (cond
+ ((and (eq (aref str 0) ?-))
+ (delete-region (match-beginning 0) (match-end 0))
+ (emacs-wiki-surround-text
+ "<ul>\n<li>" "</li>\n</ul>\n"
+ (function
+ (lambda ()
+ (and (re-search-forward "^\\s-*\\(-\\|$\\)" nil t)
+ (goto-char (match-beginning 0)))))))
+ ((and (>= (aref str 0) ?0)
+ (<= (aref str 0) ?9))
+ (delete-region (match-beginning 0) (match-end 0))
+ (emacs-wiki-surround-text
+ "<ol>\n<li>" "</li>\n</ol>\n"
+ (function
+ (lambda ()
+ (and (re-search-forward "^\\s-*\\([0-9]+\\.\\|$\\)" nil t)
+ (goto-char (match-beginning 0)))))))
+ (t
+ (goto-char (match-beginning 0))
+ (insert "<dl>\n<dt>")
+ (save-match-data
+ (when (re-search-forward "[ \t\n]+::[ \t\n]+" nil t)
+ (replace-match "</dt>\n<dd>\n")))
+ (emacs-wiki-forward-paragraph)
+ (insert "</dd>\n</dl>\n"))))))
+
+(defun emacs-wiki-markup-table ()
+ (if (featurep 'table)
+ (let ((leader (match-string 1))
+ (begin (copy-marker (match-beginning 0)))
+ table end)
+ (goto-char (match-end 0))
+ (setq table
+ (with-current-buffer (table-generate-source 'html)
+ (prog1
+ (buffer-string)
+ (kill-buffer (current-buffer)))))
+ (goto-char begin)
+ (if (re-search-backward "<p>[ \t\n\r]+" nil t)
+ (replace-match (if (>= (string-width leader) 6)
+ "<center>\n"
+ (if (> (length leader) 0)
+ "<blockquote>\n"
+ ""))))
+ (delete-region begin (re-search-forward "-+\\+\\s-*[\r\n]+\\s-*$"
+ nil t))
+ (insert table)
+ (setq end (point-marker))
+ (goto-char begin)
+ (while (< (point) end)
+ (if (looking-at "^\\s-+")
+ (replace-match ""))
+ (forward-line))
+ (goto-char end)
+ (if (re-search-forward "[ \t\n\r]+</p>" nil t)
+ (replace-match (if (>= (string-width leader) 6)
+ "\n</center>"
+ (if (> (length leader) 0)
+ "\n</blockquote>"
+ ""))))
+ (set-match-data (list begin begin begin begin))
+ nil)
+ (let* ((str (save-match-data
+ (if (featurep 'xemacs)
+ ;; more emacs divergence. :(
+ (replace-in-string (match-string 1) " *|+ *$" "")
+ (match-string 1))))
+ (fields
+ (append (save-match-data
+ (split-string str "[ \t]*|+[ \t]*"))
+ (list (match-string 4))))
+ (len (length (match-string 3)))
+ (row (cond ((= len 1) "tbody")
+ ((= len 2) "thead")
+ ((= len 3) "tfoot")))
+ (col (cond ((= len 1) "td")
+ ((= len 2) "th")
+ ((= len 3) "td"))))
+ (concat "<table " emacs-wiki-table-attributes ">\n"
+ "<" row ">\n" "<tr>\n<" col ">"
+ (mapconcat 'identity fields (format "</%s><%s>" col col))
+ "</" col ">\n" "</tr>\n" "</" row ">\n"
+ "</table>\n"))))
+
+(defun emacs-wiki-markup-verse ()
+ (save-match-data
+ (let* ((lines (split-string (match-string 1) "\n"))
+ (l lines))
+ (while l
+ (if (and (> (length (car l)) 2)
+ (string-match "\\`\\s-*> " (car l)))
+ (setcar l (substring (car l) (match-end 0))))
+ (setq l (cdr l)))
+ (concat "<p class=\"verse\">"
+ (mapconcat 'identity lines "\n") "</p>"))))
+
+(defcustom emacs-wiki-pretty-changelogs nil
+ "If non-nil, markup ChangeLog buffers using pretty tables.
+This rule requires that a GIF file called \"onepixel.gif\" be in your
+publication tree. Here is a uuencoded version of such a file:
+
+begin 644 onepixel.gif
+M1TE&.#EA`0`!`*$``````/___________R'Y!`'__P$`+``````!``$```(\"
+$3`$`.P``
+`
+end"
+ :type 'boolean
+ :group 'emacs-wiki-publish)
+
+(defun emacs-wiki-changelog-escape-files ()
+ (replace-match "[[\\1]]" t nil nil 1))
+
+(defun emacs-wiki-markup-changelog-section ()
+ (if (not emacs-wiki-pretty-changelogs)
+ "* \\1 \\2"
+ (let ((email (match-string 2))
+ (date (match-string 1)))
+ (goto-char (match-beginning 0))
+ (delete-region (match-beginning 0) (match-end 0))
+ (while (eolp)
+ (kill-line 1))
+ (insert (format " <TABLE WIDTH=\"100%%\" BORDER=\"0\"
+ CELLSPACING=\"1\" CELLPADDING=\"2\">
+ <TR>
+ <TD BGCOLOR=\"black\" BACKGROUND=\"onepixel.gif\">
+ <TABLE WIDTH=\"100%%\" BORDER=\"0\"
+ CELLPADDING=\"5\" CELLSPACING=\"0\">
+ <TR>
+ <TD ALIGN=\"left\" BGCOLOR=\"b0c4de\" BACKGROUND=\"onepixel.gif\">
+ <FONT COLOR=\"navy\"> <B>%s</B> </FONT>
+ </TD>
+ <TD ALIGN=\"right\" VALIGN=\"bottom\" BGCOLOR=\"b0c4de\"
+ BACKGROUND=\"onepixel.gif\">
+ <FONT SIZE=\"2\" COLOR=\"2f4f4f\"> %s </FONT>
+ </TD>
+ </TR>
+ <TR>
+ <TD BGCOLOR=\"fffff0\" COLSPAN=\"2\" BACKGROUND=\"onepixel.gif\">
+ <FONT COLOR=\"black\">
+" email date))
+ (add-text-properties (match-beginning 0) (point)
+ '(read-only t rear-nonsticky (read-only))))
+ (if (re-search-forward "^[0-9]" nil t)
+ (goto-char (1- (match-beginning 0)))
+ (goto-char (point-max))
+ (while (eq (char-before (1- (point))) ?\n)
+ (delete-char -1)))
+ (let ((here (1- (point))))
+ (insert "
+ </FONT>
+ </TD>
+ </TR>
+ </TABLE>
+ </TD>
+ </TR>
+ </TABLE>
+ <br>")
+ (add-text-properties here (point)
+ '(read-only t rear-nonsticky (read-only)))
+ nil)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Emacs Wiki HTTP Server (using httpd.el)
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defgroup emacs-wiki-http nil
+ "Options controlling the behaviour of the Emacs Wiki HTTP server.
+
+So, you want to run a Wiki server based on Emacs? It's simple.
+First, you will need two other scripts: httpd.el and cgi.el. Both of
+them can be downloaded from Eric Mardsen's page:
+
+ http://www.chez.com/emarsden/downloads/
+
+Once you have those two scripts, you must decide between two different
+methods of serving pages directly from Emacs:
+
+* PERSISTED INVOCATION SERVER
+
+This scheme keeps a dedicated Emacs process running, solely for the
+purpose of rendering pages. It has the disadvantage of occupying
+virtual memory when no one is requesting pages. It has the advantage
+of being 50 times faster than the next method.
+
+To use the persisted invoctaion server, you must download the Python
+script `httpd-serve' from the same website where you downloaded
+emacs-wiki:
+
+ http://www.gci-net.com/~johnw/emacs.html
+
+Once you have have downloaded the script, running it is simple:
+
+ ./httpd-serve --daemon --port 8080 --load /tmp/my-emacs-wiki \
+ [path to your HTML files]
+
+The file `/tmp/my-emacs-wiki.el' should contain all the customizations
+required by your Wiki setup. This is how the server knows where to
+find your pages. This script MUST contain the following line:
+
+ (load \"emacs-wiki\")
+
+That's it. You should now be able to access your Wiki repository at
+localhost:8080. Only world-readable will be visible, and only
+world-writable can be edited over HTTP.
+
+* AN EMACS SPAWNED PER REQUEST
+
+The old method of serving Wiki pages directly is to spawn an Emacs
+invocation for every request. This has the advantage of being a far
+simpler approach, and it doesn't consume memory if no one is
+requesting pages. The disadvantage is that it's hideously slow, and
+multiple requests may bog down your machine's supply of virtual
+memory.
+
+Anyway, to use this approach, add the following line to your
+/etc/inted.conf file:
+
+ 8080 stream tcp nowait.10000 nobody /usr/local/bin/emacs-httpd
+
+The emacs-httpd script should look something like this:
+
+ #!/bin/sh
+ /usr/bin/emacs -batch --no-init-file --no-site-file \\
+ -l httpd -l cgi -l emacs-wiki \\
+ --eval \"(setq httpd-document-root emacs-wiki-publishing-directory \\
+ emacs-wiki-maintainer \\\"mailto:joe@where.com\\\")\" \\
+ -f httpd-serve 2> /dev/null
+
+Emacs-wiki will now serve pages directly on port 8080. Note that if
+you need to configure any variables in emacs-wiki, you will have to
+repeat those configurations in the emacs-httpd script.
+
+Note: If you have the 'stopafter' tool installed, it's a good idea to
+put a limit on how much time each Emacs process is allowed. And if
+you want to render planner.el pages, you'll need to make another
+modification. Here is a more complete example:
+
+ #!/bin/sh
+ /usr/bin/stopafter 60 KILL /usr/bin/emacs \\
+ -batch --no-init-file --no-site-file \\
+ -l httpd -l cgi -l emacs-wiki -l planner \\
+ --eval \"(progn \\
+ (setq httpd-document-root emacs-wiki-publishing-directory \\
+ emacs-wiki-maintainer \\\"mailto:joe@where.com\\\") \\
+ (planner-update-wiki-project))\" \\
+ -f httpd-serve 2> /dev/null"
+ :group 'emacs-wiki)
+
+(defcustom emacs-wiki-http-search-form
+ "
+<form method=\"GET\" action=\"/searchwiki?get\">
+ <center>
+ Search for: <input type=\"text\" size=\"50\" name=\"q\" value=\"\">
+ <input type=\"submit\" value=\"Search!\">
+ </center>
+</form>\n"
+ "The form presenting for doing searches when using httpd.el."
+ :type 'string
+ :group 'emacs-wiki-http)
+
+(defcustom emacs-wiki-http-support-editing t
+ "If non-nil, allow direct editing when serving over httpd.el.
+Note that a page can be edited only if it is world-writable and
+`emacs-wiki-use-mode-flags' is set, or if it matches one of the
+regexps in `emacs-wiki-editable-pages'."
+ :type 'boolean
+ :group 'emacs-wiki-http)
+
+(defcustom emacs-wiki-http-edit-form
+ "
+<form method=\"POST\" action=\"/changewiki?post\">
+ <textarea name=\"%PAGE%\" rows=\"25\" cols=\"80\">%TEXT%</textarea>
+ <center>
+ <input type=\"submit\" value=\"Submit changes\">
+ </center>
+</form>\n"
+ "The form presenting for doing edits when using httpd.el."
+ :type 'string
+ :group 'emacs-wiki-http)
+
+(defun emacs-wiki-http-send-buffer (&optional title modified code
+ msg no-markup)
+ "Markup and send the contents of the current buffer via HTTP."
+ (unless no-markup (emacs-wiki-replace-markup title))
+ (princ "HTTP/1.0 ")
+ (princ (or code 200))
+ (princ " ")
+ (princ (or msg "OK"))
+ (princ httpd-line-terminator)
+ (princ "Server: emacs-wiki.el/2.26")
+ (princ httpd-line-terminator)
+ (princ "Connection: close")
+ (princ httpd-line-terminator)
+ (princ "MIME-Version: 1.0")
+ (princ httpd-line-terminator)
+ (princ "Date: ")
+ (princ (format-time-string "%a, %e %b %Y %T %Z"))
+ (princ httpd-line-terminator)
+ (princ "From: ")
+ (princ (substring emacs-wiki-maintainer 7))
+ (when modified
+ (princ httpd-line-terminator)
+ (princ "Last-Modified: ")
+ (princ (format-time-string "%a, %e %b %Y %T %Z" modified)))
+ (princ httpd-line-terminator)
+ (princ "Content-Type: text/html; charset=iso-8859-1")
+ (princ httpd-line-terminator)
+ (princ "Content-Length: ")
+ (princ (1- (point-max)))
+ (princ httpd-line-terminator)
+ (princ httpd-line-terminator)
+ (princ (buffer-string)))
+
+(defun emacs-wiki-http-reject (title msg &optional annotation)
+ (with-temp-buffer
+ (insert msg ".\n")
+ (if annotation
+ (insert annotation "\n"))
+ (emacs-wiki-http-send-buffer title nil 404 msg)))
+
+(defvar emacs-wiki-buffer-mtime nil)
+(make-variable-buffer-local 'emacs-wiki-buffer-mtime)
+
+(defun emacs-wiki-sort-buffers (l r)
+ (let ((l-mtime (with-current-buffer l
+ emacs-wiki-buffer-mtime))
+ (r-mtime (with-current-buffer r
+ emacs-wiki-buffer-mtime)))
+ (cond
+ ((and (null l-mtime) (null r-mtime)) l)
+ ((null l-mtime) r)
+ ((null r-mtime) l)
+ (t (emacs-wiki-time-less-p r-mtime l-mtime)))))
+
+(defun emacs-wiki-winnow-list (entries &optional predicate)
+ "Return only those ENTRIES for which PREDICATE returns non-nil."
+ (let ((flist (list t))
+ valid p)
+ (let ((entry entries))
+ (while entry
+ (if (funcall predicate (car entry))
+ (nconc flist (list (car entry))))
+ (setq entry (cdr entry))))
+ (cdr flist)))
+
+(defcustom emacs-wiki-max-cache-size 64
+ "The number of pages to cache when serving over HTTP.
+This only applies if set while running the persisted invocation
+server. See main documentation for the `emacs-wiki-http'
+customization group."
+ :type 'integer
+ :group 'emacs-wiki-http)
+
+(defun emacs-wiki-prune-cache ()
+ "If the page cache has become too large, prune it."
+ (let* ((buflist (sort (emacs-wiki-winnow-list
+ (buffer-list)
+ (function
+ (lambda (buf)
+ (with-current-buffer buf
+ emacs-wiki-buffer-mtime))))
+ 'emacs-wiki-sort-buffers))
+ (len (length buflist)))
+ (while (> len emacs-wiki-max-cache-size)
+ (kill-buffer (car buflist))
+ (setq len (1- len)))))
+
+(defun emacs-wiki-render-page (name)
+ "Render the wiki page identified by NAME.
+When serving from a dedicated Emacs process (see the httpd-serve
+script), a maximum of `emacs-wiki-max-cache-size' pages will be cached
+in memory to speed up serving time."
+ (if (equal name emacs-wiki-index-page)
+ (with-current-buffer (emacs-wiki-generate-index t t)
+ (emacs-wiki-http-send-buffer "Wiki Index")
+ (kill-buffer (current-buffer)))
+ (let ((file (and (not (emacs-wiki-private-p name))
+ (cdr (assoc name (emacs-wiki-file-alist)))))
+ (inhibit-read-only t))
+ (if (null file)
+ (emacs-wiki-http-reject "Page not found"
+ (format "Wiki page %s not found" name))
+ (set-buffer (get-buffer-create file))
+ (let ((modified-time (nth 5 (file-attributes file))))
+ (when (or (null emacs-wiki-buffer-mtime)
+ (emacs-wiki-time-less-p emacs-wiki-buffer-mtime
+ modified-time))
+ (erase-buffer)
+ (setq emacs-wiki-buffer-mtime modified-time))
+ (goto-char (point-max))
+ (if (not (bobp))
+ (emacs-wiki-http-send-buffer nil emacs-wiki-buffer-mtime
+ nil nil t)
+ (insert-file-contents file t)
+ (cd (file-name-directory file))
+ (emacs-wiki-maybe)
+ (emacs-wiki-http-send-buffer nil emacs-wiki-buffer-mtime)))
+ (set-buffer-modified-p nil)
+ (emacs-wiki-prune-cache)))))
+
+(defun emacs-wiki-wikify-search-results (term)
+ "Convert the current buffer's grep results into a Wiki form."
+ (goto-char (point-max))
+ (forward-line -2)
+ (delete-region (point) (point-max))
+ (goto-char (point-min))
+ (kill-line 2)
+ (let ((results (list t)))
+ (while (re-search-forward "^.+/\\([^/:]+\\):\\s-*[0-9]+:\\(.+\\)" nil t)
+ (let ((page (match-string 1)))
+ (unless (or (emacs-wiki-private-p page)
+ (string-match emacs-wiki-file-ignore-regexp page))
+ (let ((text (match-string 2))
+ (entry (assoc page results)))
+ (if entry
+ (nconc (cdr entry) (list text))
+ (nconc results (list (cons page (list text)))))))))
+ (delete-region (point-min) (point-max))
+ (setq results
+ (sort (cdr results)
+ (function
+ (lambda (l r)
+ (string-lessp (car l) (car r))))))
+ (while results
+ (unless (emacs-wiki-private-p (caar results))
+ (insert "[[" (caar results) "]] ::\n <p>")
+ (let ((hits (cdar results)))
+ (while hits
+ (while (string-match "</?lisp>" (car hits))
+ (setcar hits (replace-match "" t t (car hits))))
+ (while (string-match (concat "\\([^*?[/>]\\)\\<\\(" term "\\)\\>")
+ (car hits))
+ (setcar hits (replace-match "\\1<strong>\\2</strong>"
+ t nil (car hits))))
+ (insert " > <verbatim>" (car hits) "</verbatim>\n")
+ (setq hits (cdr hits))))
+ (insert "</p>\n\n"))
+ (setq results (cdr results)))))
+
+(defun emacs-wiki-setup-edit-page (page-name)
+ (insert "<verbatim>" emacs-wiki-http-edit-form "</verbatim>")
+ (goto-char (point-min))
+ (search-forward "%PAGE%")
+ (replace-match page-name t t)
+ (search-forward "%TEXT%")
+ (let ((beg (match-beginning 0))
+ (file (emacs-wiki-page-file page-name))
+ end)
+ (delete-region beg (point))
+ (when file
+ (insert-file-contents file)
+ (save-restriction
+ (narrow-to-region beg (point))
+ (goto-char (point-min))
+ (emacs-wiki-escape-html-specials)))))
+
+(defun emacs-wiki-http-changewiki (&optional content)
+ "Change the contents of Wiki page, using the results of a POST request."
+ (require 'cgi)
+ (unless content
+ (goto-char (point-min))
+ (if (not (re-search-forward "Content-length:\\s-*\\([0-9]+\\)" nil t))
+ (emacs-wiki-http-reject "Content-length missing"
+ "No Content-length for POST request"
+ (concat "Header received was:\n\n<example>"
+ (buffer-string) "</example>\n"))
+ (let ((content-length (string-to-number (match-string 1))))
+ (erase-buffer)
+ (read-event) ; absorb the CRLF separator
+ (let ((i 0))
+ (while (< i content-length)
+ (insert (read-event))
+ (setq i (1+ i))))))
+ (setq content (buffer-string)))
+ (when content
+ (let* ((result (cgi-decode content))
+ (page (caar result))
+ (text (cdar result))
+ (len (length text))
+ (require-final-newline t)
+ (pos 0) illegal user)
+ (if (not (emacs-wiki-editable-p page))
+ (emacs-wiki-http-reject
+ "Editing not allowed"
+ (format "Editing Wiki page %s is not allowed" page))
+ (while (and (null illegal)
+ (setq pos (string-match "<\\s-*\\([^> \t]+\\)"
+ text pos)))
+ (setq pos (match-end 0))
+ (if (assoc (match-string 1 text) emacs-wiki-dangerous-tags)
+ (setq illegal (match-string 1 text))))
+ (if illegal
+ (emacs-wiki-http-reject
+ "Disallowed tag used"
+ (format "Public use of <%s> tag not allowed" illegal))
+ (emacs-wiki-find-file page)
+ (if (setq user (file-locked-p buffer-file-name))
+ (emacs-wiki-http-reject
+ "Page is locked"
+ (format "The page \"%s\" is currently being edited by %s."
+ page (if (eq user t) (user-full-name) user)))
+ (let ((inhibit-read-only t)
+ (delete-old-versions t))
+ (erase-buffer)
+ (insert (if (eq (aref text (1- len)) ?%)
+ (substring text 0 (1- len))
+ text))
+ (goto-char (point-min))
+ (while (re-search-forward "\r$" nil t)
+ (replace-match "" t t))
+ (save-buffer)
+ ;; this is 0666 - there is no read syntax for octals which
+ ;; works across all emacsen
+ (let ((oct 438))
+ (when (/= (file-modes buffer-file-name) oct)
+ (set-file-modes buffer-file-name oct)))
+ (kill-buffer (current-buffer)))
+ (with-temp-buffer
+ (emacs-wiki-file-alist) ; force re-check
+ (insert "<redirect url=\"" page "\" delay=\"3\">")
+ (insert "Thank you, your changes have been saved to " page)
+ (insert ". You will be redirected to "
+ "the new page in a moment.")
+ (insert "</redirect>")
+ (emacs-wiki-http-send-buffer "Changes Saved"))))))))
+
+(defvar httpd-vars nil)
+
+(defsubst httpd-var (var)
+ "Return value of VAR as a URL variable. If VAR doesn't exist, nil."
+ (cdr (assoc var httpd-vars)))
+
+(defsubst httpd-var-p (var)
+ "Return non-nil if VAR was passed as a URL variable."
+ (not (null (assoc var httpd-vars))))
+
+(defun emacs-wiki-serve-page (page content)
+ (let ((handled t))
+ (cond
+ ((string-match "\\`wiki\\?\\(.+\\)" page)
+ (emacs-wiki-render-page (match-string 1 page)))
+
+ ((string-match "\\`editwiki\\?\\(.+\\)" page)
+ (let ((page-name (match-string 1 page)))
+ (if (not (emacs-wiki-editable-p page-name))
+ (emacs-wiki-http-reject "Editing not allowed"
+ "Editing this Wiki page is not allowed")
+ (with-temp-buffer
+ (emacs-wiki-setup-edit-page page-name)
+ ;; this is required because of the : in the name
+ (emacs-wiki-http-send-buffer
+ (concat "Edit Wiki Page: " page-name))))))
+
+ ((string-match "\\`searchwiki\\?get" page)
+ (with-temp-buffer
+ (insert "<verbatim>" emacs-wiki-http-search-form "</verbatim>")
+ (emacs-wiki-http-send-buffer "Search Wiki Pages")))
+
+ ((string-match "\\`searchwiki\\?q=\\(.+\\)" page)
+ (let ((compilation-scroll-output nil)
+ (term (match-string 1 page)))
+ (unintern 'start-process)
+ (require 'compile)
+ (with-current-buffer (emacs-wiki-grep term)
+ (emacs-wiki-wikify-search-results term)
+ (emacs-wiki-http-send-buffer "Search Results")
+ (kill-buffer (current-buffer)))))
+
+ ((string-match "\\`changewiki\\?post" page)
+ (emacs-wiki-http-changewiki content))
+
+ ((string-match "\\`diffwiki\\?\\(.+\\)" page)
+ ;; jww (2001-04-20): This code doesn't fully work yet.
+ (emacs-wiki-find-file (match-string 1 page))
+ (require 'vc)
+ (require 'vc-hooks)
+ (let ((curr-ver (vc-workfile-version buffer-file-name)))
+ (vc-version-diff buffer-file-name
+ curr-ver (vc-previous-version curr-ver))
+ (let ((inhibit-read-only t))
+ (goto-char (point-min))
+ (when (re-search-forward "^diff" nil t)
+ (forward-line)
+ (delete-region (point-min) (point)))
+ (insert "<verbatim><pre>")
+ (emacs-wiki-escape-html-specials)
+ (goto-char (point-max))
+ (if (re-search-backward "^Process.*killed" nil t)
+ (delete-region (point) (point-max)))
+ (insert "</verbatim></pre>")
+ (emacs-wiki-http-send-buffer "Diff Results"))))
+
+ (t
+ (setq handled nil)))
+ handled))
+
+(defun emacs-wiki-serve (page &optional content)
+ "Serve the given PAGE from this emacs-wiki server."
+ ;; index.html is really a reference to the main Wiki page
+ (if (string= page "index.html")
+ (setq page (concat "wiki?" emacs-wiki-home-page)))
+
+ ;; handle the actual request
+ (let ((vc-follow-symlinks t)
+ (emacs-wiki-report-threshhold nil)
+ (emacs-wiki-serving-p t)
+ httpd-vars project)
+ (save-excursion
+ ;; process any CGI variables, if cgi.el is available
+ (if (string-match "\\`\\([^&]+\\)&" page)
+ (setq httpd-vars
+ (and (fboundp 'cgi-decode)
+ (cgi-decode (substring page (match-end 0))))
+ page (match-string 1 page)))
+ (setq project (httpd-var "project"))
+ (if project
+ (with-emacs-wiki-project project
+ (emacs-wiki-serve-page page content))
+ (emacs-wiki-serve-page page content)))))
+
+(if (featurep 'httpd)
+ (httpd-add-handler "\\`\\(index\\.html\\|.*wiki\\(\\?\\|\\'\\)\\)"
+ 'emacs-wiki-serve))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Support for multile Emacs Wiki projects
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defgroup emacs-wiki-project nil
+ "Options controlling multi-project behavior in Emacs-Wiki."
+ :group 'emacs-wiki)
+
+(defvar emacs-wiki-current-project nil)
+(defvar emacs-wiki-predicate nil)
+(defvar emacs-wiki-major-mode nil)
+(defvar emacs-wiki-project-server-prefix nil)
+
+(defcustom emacs-wiki-show-project-name-p t
+ "When true, display the current project name in the mode-line"
+ :group 'emacs-wiki
+ :type 'boolean)
+
+;; this might go away - did anyone prefer the old behavior? tell me!
+(defvar emacs-wiki-old-project-change-p nil)
+
+(defcustom emacs-wiki-update-project-hook
+ '(emacs-wiki-update-project-interwikis)
+ "A hook called whenever `emacs-wiki-projects' is modified.
+By default, this hook is used to update the Interwiki table so that it
+contains links to each project name."
+ :type 'hook
+ :group 'emacs-wiki-project)
+
+(defun emacs-wiki-update-project-interwikis ()
+ (let ((projs emacs-wiki-projects))
+ (while projs
+ (add-to-list
+ 'emacs-wiki-interwiki-names
+ `(,(caar projs)
+ . (lambda (tag)
+ (emacs-wiki-project-interwiki-link ,(caar projs) tag))))
+ (setq projs (cdr projs)))))
+
+(defcustom emacs-wiki-projects nil
+ "A list of project-specific Emacs-Wiki variable settings.
+Each entry is a cons cell, of the form (PROJECT VARS).
+
+Projects are useful for maintaining separate wikis that vary in
+some way. For instance, you might want to keep your work-related
+wiki files in a separate directory, with a different fill-column:
+
+(setq emacs-wiki-projects
+ `((\"default\" . ((emacs-wiki-directories . (\"~/wiki\"))))
+ (\"work\" . ((fill-column . 65)
+ (emacs-wiki-directories . (\"~/workwiki/\"))))))
+
+You can then change between them with \\[emacs-wiki-change-project],
+by default bound to C-c C-v. When you use \\[emacs-wiki-find-file] to
+find a new file, emacs-wiki will attempt to detect which project it
+is part of by finding the first project where emacs-wiki-directories
+contains that file.
+
+VARS is an alist of symbol to value mappings, to be used locally in
+all emacs-wiki buffers associated with that PROJECT.
+
+You may also set the variable `emacs-wiki-predicate' in this alist,
+which should be a function to determine whether or not the project
+pertains to a certain buffer. It will be called within the buffer in
+question. The default predicate checks whether the file exists within
+`emacs-wiki-directories' for that project.
+
+The variable `emacs-wiki-major-mode' can be used to determine the
+major mode for a specific emacs-wiki buffer, in case you have
+developed a customized major-mode derived from `emacs-wiki-mode'.
+
+The variable `emacs-wiki-project-server-prefix' is prepended to the
+Interwiki URL, whenever an Interwiki reference to another project is
+made. For example, if you had two projects, A and B, and in A you
+made a reference to B by typing B#WikiPage, A needs to know what
+directory or server to prepend to the WikiPage.html href. If this
+variable is not set, it is assumed that both A and B publish to the
+same location.
+
+If any variable is not customized specifically for a project, the
+global value is used."
+ :type `(repeat
+ (cons
+ :tag "Emacs-Wiki Project"
+ (string :tag "Project name")
+ (repeat
+ (choice
+ (cons :tag "emacs-wiki-predicate"
+ (const emacs-wiki-predicate) function)
+ (cons :tag "emacs-wiki-major-mode"
+ (const emacs-wiki-major-mode) function)
+ (cons :tag "emacs-wiki-project-server-prefix"
+ (const emacs-wiki-project-server-prefix) string)
+ ,@(mapcar
+ (function
+ (lambda (sym)
+ (list 'cons :tag (symbol-name sym)
+ (list 'const sym)
+ (get sym 'custom-type))))
+ (apropos-internal "\\`emacs-wiki-"
+ (function
+ (lambda (sym)
+ (and (not (eq sym 'emacs-wiki-projects))
+ (get sym 'custom-type))))))))))
+ :set (function
+ (lambda (sym val)
+ (set sym val)
+ (run-hooks 'emacs-wiki-update-project-hook)))
+ :group 'emacs-wiki-project)
+
+(defmacro with-emacs-wiki-project (project &rest body)
+ "Evaluate as part of PROJECT the given BODY forms."
+ `(with-temp-buffer
+ (emacs-wiki-change-project ,project)
+ ,@body))
+
+(put 'with-emacs-wiki-project 'lisp-indent-function 1)
+
+(defun emacs-wiki-change-project (project)
+ "Manually change the project associated with the current buffer."
+ (interactive (list (completing-read "Switch to project: "
+ emacs-wiki-projects
+ nil t nil)))
+ (let ((projsyms (cdr (assoc project emacs-wiki-projects)))
+ sym)
+ (while projsyms
+ (setq sym (caar projsyms))
+ (unless (memq sym '(emacs-wiki-predicate emacs-wiki-major-mode))
+ (let ((custom-set (or (get sym 'custom-set) 'set))
+ (var (if (eq (get sym 'custom-type) 'hook)
+ (make-local-hook sym)
+ (make-local-variable sym))))
+ (if custom-set
+ (funcall custom-set var (cdar projsyms)))))
+ (setq projsyms (cdr projsyms))))
+ (when (not (string= emacs-wiki-current-project project))
+ ;; if it was a user request to change, change to the welcome buffer first
+ (if (and (interactive-p)
+ (not emacs-wiki-old-project-change-p))
+ (with-emacs-wiki-project
+ project (emacs-wiki-visit-link emacs-wiki-default-page))
+ (set (make-local-variable 'emacs-wiki-current-project) project)
+ (when emacs-wiki-show-project-name-p
+ (setq mode-name (concat "Wiki[" project "]"))))))
+
+(defun emacs-wiki-project-interwiki-link (project tag)
+ (with-emacs-wiki-project project
+ (if emacs-wiki-publishing-p
+ (concat emacs-wiki-project-server-prefix
+ (emacs-wiki-link-url (or tag emacs-wiki-home-page)))
+ (or (emacs-wiki-page-file (or tag emacs-wiki-home-page))
+ ;; doesn't yet exist, so we don't qualify the name, causing it to be
+ ;; rendered as a bad link
+ tag))))
+
+(provide 'emacs-wiki)
+;;; emacs-wiki.el ends here
--- /dev/null
+;;; mode-compile.el --- Smart command for compiling files
+;; according to major-mode.
+;;
+;; Copyright (c) 1994 - 2003 heddy Boubaker C.E.N.A.
+;;
+;; Author: Heddy Boubaker <heddy.Boubaker@cena.fr>
+;; Maintainer: Heddy Boubaker <heddy.Boubaker@cena.fr>
+;; Created: June 1994
+;; Last modified: 2003/04/01 13:52:47
+;; Version: 2.28
+;; Keywords: compile, compilation, modes, languages
+;; Tested for:
+;; XEmacs (Lucid GNU Emacs) >= 19.10
+;; Must work with FSF GNU Emacs > 19.31 ;-)
+;; Do not work anymore for Emacses <= 18
+;; Ftp access:
+;; archive.cis.ohio-state.edu:pub/gnu/emacs/elisp-archive/misc/mode-compile.el.Z
+;; WWW access:
+;; <URL http://www.tls.cena.fr/~boubaker/Emacs/>
+;;
+;; LCD Archive Entry:
+;; mode-compile|Heddy Boubaker|boubaker@cena.fr|
+;; Smart command for compiling files according to major-mode and more.|
+;; 2003/04/01 13:52:47|2.28|~/misc/mode-compile.el.Z|
+;;
+;;; This file is NOT part of GNU Emacs but the same permissions apply.
+;;
+;; GNU Emacs is free software; you can redistribute it and/or modify it under
+;; the terms of the GNU General Public License as published by the Free
+;; Software Foundation; either version 2, or (at your option) any later
+;; version.
+;;
+;; GNU Emacs is distributed in the hope that it will be useful, but WITHOUT
+;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
+;; more details.
+;;
+;; You should have received a copy of the GNU General Public License along
+;; with GNU Emacs; see the file COPYING. If not, write to the Free Software
+;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;;
+;; @ Purpose:
+;; ==========
+;;
+;; Provide `mode-compile' function as a replacement for the use of `compile'
+;; command which is very dumb for creating it's compilation command (use
+;; "make -k" by default). `mode-compile' is a layer above `compile'; Its
+;; purpose is mainly to build a smart compile-command for `compile' to
+;; execute it. This compile-command is built according to number of
+;; parameters:
+;; - the major-mode.
+;; - presence or not of a makefile in current directory.
+;; - the buffer-file-name and extension.
+;; - what is in the current buffer (`main' function,"#!/path/shell", ...).
+;; - and more ... (see Commentary section below).
+;; Most of these parameters are higly customizable throught Emacs Lisp
+;; variables (to be set in your .emacs or through Customization menu).
+;; Running mode-compile after an universal-argument (C-u) allows remote
+;; compilations, user is prompted for a host name to run the compilation
+;; command on. Another function provided is `mode-compile-kill' which
+;; terminate a running compilation session launched by `mode-compile'.
+;;
+;; @ Installation:
+;; ===============
+;;
+;; Byte compile this file (*) somewhere in your `load-path' and add in
+;; your .emacs:
+;; (autoload 'mode-compile "mode-compile"
+;; "Command to compile current buffer file based on the major mode" t)
+;; (global-set-key "\C-cc" 'mode-compile)
+;; (autoload 'mode-compile-kill "mode-compile"
+;; "Command to kill a compilation launched by `mode-compile'" t)
+;; (global-set-key "\C-ck" 'mode-compile-kill)
+;;
+;; By default mode-compile is very verbose and waits a few seconds (1 by
+;; default) after each message for the user to have time to read it. You
+;; could set variables `mode-compile-expert-p' and
+;; `mode-compile-reading-time' to change this behaviour. On X-Windows
+;; systems setting the variable `mode-compile-other-frame-p' will create a
+;; new frame and launch the compilation command in it.
+;;
+;; (*) Don't take care of messages:
+;; ** reference to free variable efs-remote-shell-file-name
+;; This is perfectly normal ;-}. But if you know a way to avoid it let me
+;; know.
+;;
+;; @ Bug Reports:
+;; ==============
+;;
+;; To report a bug please use function `mode-compile-submit-bug-report'
+;; Please note that this bug-report facility uses Barry Warsaw's reporter.el
+;; which is part of GNU Emacs v19 and bundled with many other packages. If
+;; needed, you can obtain a copy of reporter.el at the elisp-archive.
+;;
+;; @ Documentation:
+;; ================
+;;
+;; This section will explain how the `compile-command' are built according to
+;; the `major-mode' and how to customize it. The major modes `mode-compile'
+;; currently known are:
+;; - c-mode, c++-mode, makefile-mode, dired-mode, ada-mode, emacs-lisp-mode,
+;; lisp-interaction-mode, sh-mode, csh-mode, fundamental-mode, text-mode,
+;; indented-text-mode compilation-mode, fortran-mode, c?perl-mode,
+;; zsh-mode java-mode, tcl-mode, python-mode
+;; For other modes a default behaviour is provided.
+;;
+;; When running `mode-compile' or `mode-compile-kill' the hooks
+;; `mode-compile-(before|after)-(compile|kill)-hook' are executed. The
+;; current buffer could be automaticaly saved if variable
+;; `mode-compile-always-save-buffer-p' is set to `t'. ALL the modified
+;; buffers could be automaticaly saved if variable `mode-compile-save-all-p'
+;; is set to `t'.
+;;
+;; @@ fundamental-mode, text-mode, indented-text-mode & UNKNOWN MODES:
+;; *** THIS IS TOO THE DEFAULT BEHAVIOR FOR UNKNOWN MODES ***
+;; Try to guess what the file is by:
+;; - 1st looking at it's name and extension (see variable
+;; `mode-compile-filename-regexp-alist').
+;; - 2nd looking at string "#!/path/shell" at first line to extract shell
+;; to run the script with (see variable `mode-compile-shell-alist').
+;; - 3rd looking at a makefile in current directory.
+;; - then calling `compile' with the last compile command which is
+;; asked to be edited by user ...
+;; The `kill-compile' command is then bound dynamically (buffer-local).
+;;
+;; @@ compilation-mode:
+;; Call `compile' with the last compile command.
+;;
+;; @@ makefile-mode:
+;; The makefile is run with make throught `compile' (user is prompted
+;; for the rule to run, see variable
+;; `mode-compile-prefered-default-makerule' to see how a default choice
+;; could be selected).
+;;
+;; @@ emacs-lisp-mode, lisp-interaction-mode:
+;; If the buffer is a .el file byte-compile it to produce a .elc file,
+;; else just byte-compile the buffer (this don't use `compile' but
+;; `byte-compile').
+;;
+;; @@ dired-mode:
+;; Find a makefile in the directory and run make with it (like in
+;; makefile-mode), else try to byte-recompile all .el files olders than
+;; their associated .elc files (unlike `byte-recompile-directory' this is
+;; not recursive), finally if no .el files are present ask compilation
+;; command to user by calling `default-compile'. To find a makefile a
+;; regexp is provided which name is `mode-compile-makefile-regexp'.
+;;
+;; @@ sh-mode, csh-mode, zsh-mode:
+;; Run "[cz]?sh" with debugging arguments as specified in
+;; `[cz]?sh-dbg-flags' on the currently edited file.
+;;
+;; @@ c?perl-mode:
+;; Run file with "perl -w" (can step throught errors with compile's
+;; `next-error' command).
+;;
+;; @@ tcl-mode:
+;; Run file with "wish" (can step throught errors with compile's
+;; `next-error' command).
+;;
+;; @@ c-mode, c++-mode:
+;; First it try to see if there is a makefile in the directory, makefiles to
+;; look for are specified by the variable `mode-compile-makefile-regexp'.
+;; If yes two cases could happen: there is only one makefile so use it, or
+;; there is more than one (sometimes when you need to write portable soft
+;; you could have some makefiles by system: SunOs.make, HP.make ...), in
+;; that case prompt to user for choice (with smart completion). Once the
+;; makefile has been selected it extract the rules from it and ask to user
+;; to choose a rule to make (with smart completion, see variable
+;; `mode-compile-prefered- default-makerule' to see how a default choice
+;; could be selected).
+;;
+;; There are some cases where no makefiles are presents (YES I KNOW this is
+;; bad practice but you sometimes have no needs to write a Makefile). In
+;; that case the function try to build the most intelligent compilation
+;; command by using the favourite user C/C++ compiler: value of environment
+;; variable "CC" or "CXX" or first found, in the PATH, of compilers
+;; specified in variable `cc-compilers-list' or `c++-compilers-list'. Then
+;; it look for the varenv "CFLAGS" of "CXXFLAGS" to append to the compiler
+;; command, find the file to compile:
+;; <name-of-the-file-to-compiled>.(c|cc|C|cpp) (see *) and ask for
+;; confirmation. If you really trust mode-compile will build the right
+;; command and want to bypass confirmation you could set the variable
+;; `mode-compile-never-edit-command-p' to t.
+;;
+;; (*) How to find <name-of-the-file-to-compiled>:
+;; In both case the command try to guess which file has to be compiled:
+;; It's a trivial choice when current buffer file is a
+;; .(c|C|cc|cpp... -any file with extension specified in
+;; `cc-source-file-ext-list' or `c++-source-file-ext-list') file but
+;; when it's a .(h|H|hh) file what to do? The variable
+;; `cc-companion-file-regexp' or `c++-companion-file-regexp' specify
+;; how to find a .(c|C|cc|cpp...) file from a .(h|H|hh...); This is
+;; done by appending .(c|C|cc|cpp) to
+;; <filename-without-matching-regexp>. In c-mode with default value
+;; it produce:
+;; file.h, file_[Pp].h -> file.c
+;; I sometimes use files _p.h to indicate that the file is a private header
+;; file for a .c file.
+;; In c++-mode with default value it produce:
+;; file.hh, file_[Pp].hh -> file.cc
+;; I sometimes use files _p.cc to indicate that the file is a private header
+;; file for a .cc file.
+;; The output of compilation will be a
+;; <name-of-the-file-to-compiled>.o file if no `main' function is
+;; found inside or a <name-of-the-file-to-compiled> EXECUTABLE file
+;; if `main' function found.
+;;
+;; @@ ada-mode:
+;; Same as c/c++-mode but run Ada compiler on the Ada file. There are no
+;; companion file and no way to find a main function in Ada.
+;;
+;; @@ fortran-mode:
+;; Same as c-mode but run Fortran compiler on .[Ff](or)? files.
+;;
+;; @@ java-mode:
+;; Same as c-mode but call "javac" without the -o option on .java files
+;;
+;; @@ python-mode:
+;; Run file with "python" (can step throught errors with compile's
+;; `next-error' command).
+;;
+;; @@ message-mode:
+;; Run `message-send'.
+;;
+;; @ WhatsNew:
+;; ===========
+;;
+;; Support for cperl-mode
+;; Require cl
+;;
+;; @ Contributors/Helpers:
+;; =======================
+;;
+;; Adrian Aichner <aichner@ecf.teradyne.com>
+;; "William A. Perkins" <wa_perkins@pnl.gov>
+;; Bin Mu <mubin@DerivaTech.COM>
+;; Gael MARZIOU <Gael_Marziou@grenoble.hp.com>
+;; Christian Motschke <motschke@prosun.first.gmd.de>
+;; boris <boris@cs.rochester.edu>
+;; Edward Hartnett <ejh@larry.gsfc.nasa.gov>.
+;; Hartmut MANZ <manz@intes-stuttgart.de>.
+;; Henry Guillaume <henryg@tusc.com.au>.
+;; Ian Young <imy@wcl-rs.bham.ac.uk>
+;; Ilya Zakharevich <ilya@math.ohio-state.edu>.
+;; Kevin Broadey <KevinB@bartley.demon.co.uk>.
+;; Lawrence R. Dodd <dodd@roebling.poly.edu>.
+;; Martin Jost <asictest@ztivax.zfe.siemens.de>.
+;; Michael Welsh Duggan <md5i+@andrew.cmu.edu>.
+;; Rolf EBERT <rolf@gundog.lbl.gov>.
+;; Scott Hofmann <scotth@visix.com>.
+;; Stefan Schoef <Stefan.Schoef@arbi.informatik.uni-oldenburg.de>.
+;; John W. Harwell <ccjohnh@showme.missouri.edu> - JWH.
+;;
+;; @ ToDo:
+;; =======
+;;
+;; Extending this to some others programming languages (modes).
+;; Writting an Info documentation.
+;; Contributors are greatly accepted (send me diffs and don't forget to
+;; update documentation and all comments too please).
+;; Maybe Using ange-ftp parse .netrc utilities for remote host and
+;; user infos.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+\f
+
+;; @ Requirements ;;;
+
+;; mode-compile is not a replacement for compile
+;; it is just a layer above it.
+(require 'compile)
+;;; For Emacs-Lisp files compilations
+(require 'byte-compile "bytecomp")
+;;; For easy macros
+(require 'backquote)
+(require 'cl)
+(load-library "cl-macs")
+;; Pretty print elisp
+(require 'pp)
+;;; Setting obsolete vars
+(eval-and-compile
+ (condition-case ()
+ (require 'obsolete)
+ (error nil))
+ (if (and (featurep 'obsolete) (fboundp 'define-obsolete-variable-alias))
+ nil ;; We've got what we needed
+ (defmacro define-obsolete-variable-alias (old new)
+ (` (progn (defalias (, old) (, new))
+ (put (, old) 'byte-obsolete-variable (, new)))
+ ))))
+;;; For using custom - stolen from w3-cus.el -
+(eval-and-compile
+ (condition-case ()
+ (require 'custom)
+ (error nil))
+ (if (and (featurep 'custom) (fboundp 'custom-declare-variable))
+ nil ;; We've got what we needed
+ ;; We have the old custom-library, hack around it!
+ (defmacro defgroup (&rest args)
+ nil)
+ (defmacro defcustom (var value doc &rest args)
+ (` (defvar (, var) (, value) (, doc))))))
+
+;; Custom groups
+(defgroup compilation nil
+ "Compilations from within Emacs variables."
+ :link '(url-link :tag "Author's Emacs Page"
+ "http://www.tls.cena.fr/~boubaker/Emacs/")
+ :group 'tools
+ :group 'development)
+(defgroup compilation-lang nil
+ "Language specific compilation options."
+ :group 'languages
+ :group 'compilation)
+(defgroup compilation-script nil
+ "Scripts compilation options."
+ :group 'compilation)
+(defgroup compilation-elisp nil
+ "Emacs developpement compilation options."
+ :group 'lisp
+ :group 'compilation)
+
+;; @ User variables ;;;
+;; @@ Common variables to mode-compile for all modes ;;;
+
+(defcustom mode-compile-modes-alist
+ '((c-mode . (cc-compile kill-compilation))
+ (java-mode . (java-compile kill-compilation))
+ (c++-mode . (c++-compile kill-compilation))
+ (ada-mode . (ada-compile kill-compilation))
+ (fortran-mode . (f77-compile kill-compilation))
+ (dired-mode . (dired-compile kill-compilation))
+ (emacs-lisp-mode . (elisp-compile keyboard-quit)) ; I'm SURE IT'S NOT the best way
+ (lisp-interaction-mode . (elisp-compile keyboard-quit)) ; to kill a byte-compilation.
+ (makefile-mode . (makefile-compile kill-compilation))
+ (sh-mode . (sh-compile kill-compilation))
+ (csh-mode . (csh-compile kill-compilation))
+ (zsh-mode . (zsh-compile kill-compilation))
+ (perl-mode . (perl-compile kill-compilation))
+ (cperl-mode . (perl-compile kill-compilation))
+ (tcl-mode . (tcl-compile kill-compilation)) ; JWH
+ (python-mode . (python-compile kill-compilation)) ; BM
+ ;(message-mode . (message-compile kill-compilation))
+ (fundamental-mode . (guess-compile nil)) ; bound dynamically
+ (text-mode . (guess-compile nil)) ; itou
+ (indented-text-mode . (guess-compile nil)) ; itou
+ (compilation-mode . (default-compile kill-compilation)))
+ "Assoc list of compile/kill functions for some known modes.
+
+Each element look like (MODE . (COMPILE-FUNCTION KILL-FUNCTION))
+ `mode-compile' will call COMPILE-FUNCTION and `mode-compile-kill'
+ KILL-FUNCTION if current major-mode is MODE.
+
+If you want to add or modify a COMPILE-FUNCTION and it's associated
+KILL-FUNCTION for MODE and don't want to hack `mode-compile' you could
+do the following (it exists however a more subtle method for
+modifying, this is left as an exercice for the reader :-):
+ (defun my-mode-compile() ...)
+ (defun my-mode-compile-kill() ...)
+ (setq mode-compile-modes-alist
+ (append '((my-mode . (my-mode-compile my-mode-compile-kill)))
+ mode-compile-modes-alist))"
+ :type '(repeat
+ (cons :tag "Association: mode/compilation functions"
+ (function :tag "Mode")
+ (list :tag "Compilation functions"
+ (choice :tag "Function to run the compilation"
+ (function-item :tag "Default" :value default-compile)
+ (function-item :tag "Guess" :value guess-compile)
+ (function-item :tag "Emacs lisp byte compilation" :value elisp-compile)
+ (function :tag "Your choice, take care..."))
+ (choice :tag "Function to kill a running compilation"
+ (function-item :tag "Just kill" :value kill-compilation)
+ (const :tag "Nothing -- use with guess-compile --" :value nil)
+ (function-item :tag "To use with elisp-compile" :value keyboard-quit)
+ ;; This item could not be selected due to a custom (hum) feature ...
+ (function :tag "Your choice, take care..." :value nil)))))
+ :group 'compilation)
+
+(defcustom mode-compile-filename-regexp-alist
+ ;; These could be in auto-mode-alist. But if you are like me
+ ;; and don't like these modes (prefear to edit these kind of
+ ;; files in text-mode) this is a nice way to compile them
+ ;; without to be bored with their associated modes.
+ '((mode-compile-makefile-regexp . makefile-mode)
+ ("\\.sh$" . sh-mode)
+ ("\\.csh$" . csh-mode)
+ ("\\.zsh$" . zsh-mode))
+ "Assoc list of major-modes for some filenames regexp.
+
+Each element look like (REGEXP . MODE) This variable is really similar
+to `auto-mode-alist' in the fact that it associate a MODE to a REGEXP
+matching a filename. The only differences is that you are not obliged
+to have the specified MODE available to use it (`guess-compile' use
+it), the MODE is only a pointer to an assoq in
+`mode-compile-modes-alist' to get the COMPILE-FUNCTION and the
+KILL-FUNCTION. The REGEXP could be a form wich evaluate to a string.
+
+To add a new filename regexp do the following:
+ (setq mode-compile-filename-regexp-alist
+ (append '((my-filename-regexp . some-mode-mode-compile-know)
+ mode-compile-modes-alist))"
+ :type '(repeat
+ (cons :tag "Association: filename/mode"
+ (choice :tag "Filename regexp match"
+ (regexp :tag "Regexp as a string")
+ (symbol :tag "Variable containing the regexp")
+ (sexp :tag "Form wich evaluate to a string"))
+ ;; I need to bind dynamicaly this with const, ideas??
+ ;;`(choice
+ ;; ,@(mapcar (lambda (x) `(const ,(car x))) mode-compile-modes-alist))))
+ (function :tag "Mode to use -- should be a valid assoq in mode-compile-modes-alist --")))
+ :group 'compilation)
+
+(defcustom mode-compile-shell-alist
+ '(("sh" . sh-mode)
+ ("csh" . csh-mode)
+ ("zsh" . zsh-mode)
+ ("perl" . perl-mode)
+ ("tcl" . tcl-mode) ; JWH
+ ("python" . python-mode)) ; BM
+ "Assoc list of compile function for some known shells.
+
+Each element look like (SHELL . MODE) This variable look like
+`auto-mode-alist' in the fact that it associate a MODE to a name; A
+SHELL name here. The main difference is that you are not obliged to
+have the specified MODE available to use it (`guess-compile' use it),
+the MODE is only a pointer to an assoq in `mode-compile-modes-alist'
+to get the COMPILE-FUNCTION and the KILL-FUNCTION.
+
+To add a new shell do the following:
+ (setq mode-compile-filename-shell-alist
+ (append '((my-shell-name . some-mode-mode-compile-know)
+ mode-compile-modes-alist))"
+ :type '(repeat
+ (cons :tag "Association: shell name/mode"
+ (string :tag "Shell name")
+ ;; I need to bind dynamicaly this with const, ideas??
+ ;;`(choice
+ ;; ,@(mapcar (lambda (x) `(const ,(car x))) mode-compile-modes-alist))))
+ (function :tag "Mode to use -- should be a valid assoq in mode-compile-modes-alist --")))
+ :group 'compilation)
+
+;;;###autoload
+(defcustom mode-compile-make-program "make"
+ "*The `make' program used to process makefiles.
+
+If you have GNU make installed with name \"gmake\" use it."
+ :type 'string
+ :group 'compilation)
+
+(defcustom mode-compile-makefile-regexp
+ "\\(^[Mm]akefile\\|.*\\.[mM][aA]?[kK][eE]?\\.?.*$\\)"
+ "Regexp matching 'could be' makefiles filenames."
+ :type 'regexp
+ :group 'compilation)
+
+(defcustom mode-compile-makefile-backups-regexp
+ "\\(\\(~\\|\\.[bB][aA][cC]?[kK]\\)$\\)\\|\\(\\(^\\|/\\)[.,][^/]+$\\)"
+ "Regexp to find if a Makefile is a backup or not"
+ :type 'regexp
+ :group 'compilation)
+
+;;;###autoload
+(defcustom mode-compile-ignore-makefile-backups t
+ "*Tell mode compile to ignore makefiles backup files when selecting the Makefile to use."
+ :type 'boolean
+ :group 'compilation)
+
+;;;###autoload
+(defvar mode-compile-default-make-options "-k"
+ "Default options to give to `make'.")
+;;;###autoload
+(defcustom mode-compile-make-options (eval mode-compile-default-make-options)
+ "*Options to give to `make'.
+This could be any form evaluating to a string.
+
+Some people asked me a way to modify the make options everytime a
+compilation command is launched, do that:
+ (defun my-mode-compile-ask-make-options()
+ \"*Hook called by mode-compile, asking for make options.\"
+ (interactive)
+ (read-string \"Make options: \"
+ mode-compile-default-make-options))
+ (setq mode-compile-make-options
+ 'my-mode-compile-ask-make-options)"
+ :type '(choice
+ string
+ (sexp :tag "Form evaluating to a string"))
+ :group 'compilation)
+
+;;;###autoload
+(defcustom mode-compile-prefered-default-makerule 'none
+ "*Default makerule you would like to see in minibuffer as a default choice
+when selecting the make rule to build.
+
+Possible values are:
+'none -- let mode-compile deciding for you.
+'all -- try hard to show you the \"all\" rule.
+'default -- try hard to show you the \"default\" rule.
+'file -- try to show you the name of the file which will be
+ result of compilation.
+The 'none action is taken as default is something fail."
+ :type '(radio :tag "Symbol"
+ (const :tag "None - Let mode compile made the choice" :value none)
+ (const :tag "All - Show the \"all\" rule" :value all)
+ (const :tag "Default - Show the \"default\" rule" :value default)
+ (const :tag "File - Show the \"result file name\" rule" :value file))
+ :group 'compilation)
+
+;;;###autoload
+(defcustom mode-compile-ignore-makerule-regexp nil
+ "*Makefile rules which must be ignored when building completion list.
+
+For example if you want to remove all `files rules' set
+it to: \"\\\\.\\\\([aoc]\\\\|s[ao][.0-9]*\\\\)\". "
+ :type '(choice (const :tag "none" :value nil)
+ (const :tag "The `all files' rule" :value "\\.\\([aoc]\\|s[ao][.0-9]*\\)")
+ regexp)
+ :group 'compilation)
+
+;;;###autoload
+(defcustom mode-compile-save-all-p nil
+ "*Non-nil means save ALL the modified buffers without asking
+before launching compilation command."
+ :type 'boolean
+ :group 'compilation)
+
+;;;###autoload
+(defcustom mode-compile-always-save-buffer-p nil
+ "*Non-nil means save the current buffer without asking
+before launching compilation command."
+ :type 'boolean
+ :group 'compilation)
+
+;;;###autoload
+(defcustom mode-compile-never-edit-command-p nil
+ "*Non-nil means never ask to user to edit the compile command."
+ :type 'boolean
+ :group 'compilation)
+
+;; @@ Compilation in other frame vars ;;;
+(defgroup compilation-frame nil
+ "Compile in another frame variables."
+ :group 'frames
+ :group 'compilation)
+
+;;;###autoload
+(defcustom mode-compile-other-frame-p nil
+ "*Non-nil means compile in another frame.
+
+A new Emacs FRAME is created and the compilation command is executed
+in this other frame. To specify the frame parameters see also
+variable `mode-compile-frame-parameters-alist'."
+ :type 'boolean
+ :group 'compilation-frame)
+
+(defcustom mode-compile-other-frame-name "COMPILATION"
+ "Name of mode-compile's other frame.
+
+This name could be used in your .Xdefault or .Xresources file as:
+Emacs.MODE-COMPILE-OTHER-FRAME-NAME.resource_to_be_set: ..."
+ :type 'string
+ :group 'compilation-frame)
+
+(defconst mode-compile-default-frame-parameters
+ (list
+ (cons 'name mode-compile-other-frame-name)
+ (cons 'width 85) ; columns
+ (cons 'height 30)) ; lines
+ "Default parameters for mode-compile's other frame.")
+
+(defvar mode-compile-frame-parameters-alist
+ (purecopy mode-compile-default-frame-parameters)
+ "Parameters for the new Compilation Screen created
+if variable `mode-compile-other-frame-p' is non nil..
+
+See also variable `mode-compile-default-frame-parameters' and
+`mode-compile-other-frame-name'.
+
+For informations about Screen/Frame parameters see:
+- Info, Nodes: Lispref::Screen::Screen Parameters
+- GNU Emacs Lisp Reference Manual, chapter 26 p375: Frames.")
+
+;; @@ Hooks ;;;
+
+;;;###autoload
+(defcustom mode-compile-before-compile-hook nil
+ "Hook to be run before compile command is executed
+when `mode-compile' is invoked."
+ :type 'hook
+ :group 'compilation)
+
+;;;###autoload
+(defcustom mode-compile-after-compile-hook nil
+ "Hook to be run after compile command is executed
+when `mode-compile' is invoked."
+ :type 'hook
+ :group 'compilation)
+
+;;;###autoload
+(defcustom mode-compile-before-kill-hook nil
+ "Hook to be run before killing compile command is executed
+when `mode-compile-kill' is invoked."
+ :type 'hook
+ :group 'compilation)
+
+;;;###autoload
+(defcustom mode-compile-after-kill-hook nil
+ "Hook to be run after killing compile command is executed
+when `mode-compile-kill' is invoked."
+ :type 'hook
+ :group 'compilation)
+
+;; @@ System dependencies ;;;
+
+(defvar mode-compile-exe-file-ext
+ (cond
+ ((memq system-type '(ms-dos emx windows-95 windows-98 windows-nt)) ".exe")
+ (t ""))
+ "*Extension of executable files (with dot included)")
+
+(defvar mode-compile-dir-separator-char
+ (cond
+ ;; MSDOSish file systems
+ ((memq system-type '(ms-dos emx windows-95 windows-98 windows-nt)) "\\")
+ ;; Unixish file systems
+ (t "/"))
+ "*Separator char between directories")
+
+;; @@ Facilities variables ;;;
+
+;;;###autoload
+(defvar mode-compile-choosen-compiler nil
+ "*Global variable containing the name of the compiler
+which will be used for compiling without makefile.
+
+ Could be used in combination with
+ (cc|c++|ada|f77)-default-compiler-options
+to automaticaly choose the compiler specific options.
+
+example:
+ (defun my-compiler-get-options()
+ (cond
+ ((string= mode-compile-choosen-compiler \"gcc\")
+ \"-Wall -pedantic-errors\")
+ ((string= mode-compile-choosen-compiler \"cc\")
+ \"cc options whatever they are...\")
+ (t
+ (message \"Don't know this compiler: %s\" mode-compile-choosen-compiler)
+ (read-string
+ (format \"Options for %s compiler: \" mode-compile-choosen-compiler)))))
+
+ (setq cc-default-compiler-options 'my-compiler-get-options)")
+
+;; @@ User level ;;;
+
+;;;###autoload
+(defcustom mode-compile-expert-p nil
+ "*Non nil means `mode-compile' will not speaks too much.
+
+See also variable variable mode-compile-reading-time."
+ :type 'boolean
+ :group 'compilation)
+
+;;;###autoload
+(defcustom mode-compile-reading-time 1
+ "*Seconds to wait in verbose mode after printing a message.
+
+In verbose mode mode-compile print too much messages that it is
+allmost impossible to read them. Just setting this delay leave you the
+time to read all the messages. If you don't want any delay set it to
+`0'.
+
+See also function sit-for."
+ :type 'integer
+ :group 'compilation)
+\f
+
+;; @@ Remote compilation vars ;;;
+(defgroup compilation-remote nil
+ "Remote compilations options."
+ :group 'compilation)
+
+(defcustom mode-compile-remote-hosts-alist '()
+ "Alist of favourites hosts names and the username
+to use to log on (HOSTNAME . USERNAME).
+
+If USERNAME is a function it will be called with HOSTNAME as argument
+and should return an USERNAME string (for example you could use
+something like efs-get-user - not tested -), if it is nil the function
+user-login-name will be used."
+ :type '(repeat
+ (cons
+ (string :tag "Hostname")
+ (choice
+ (const :tag "We'll use \'user-login-name" :value nil)
+ (string :tag "Username")
+ (function :tag "Function which return USERNAME given a HOSTNAME" :value efs-get-user))))
+ :group 'compilation-remote)
+
+(defcustom mode-compile-remote-execute-command "rsh"
+ "The shell command used to run a command remotely.
+\"rsh\" is the only choice I know but I'm far to know everything...
+
+ This variable is set automaticaly with the value of
+remote-shell-program or efs-remote-shell-file-name at load time."
+ :type 'string
+ :group 'compilation)
+(eval-when 'load
+ (cond
+ ((not (string= mode-compile-remote-execute-command "rsh"))
+ ;; user changed default
+ nil)
+ ;; Try to not multiply definitions of the same stuff
+ ;; in too many emacs lisp packages ...
+ ((and (boundp 'remote-shell-program) remote-shell-program)
+ (setq mode-compile-remote-execute-command remote-shell-program))
+ ((and (boundp 'efs-remote-shell-file-name) efs-remote-shell-file-name)
+ (setq mode-compile-remote-execute-command efs-remote-shell-file-name))
+ ))
+
+(defcustom mode-compile-remote-execute-set-host-arg ""
+ "Argument To set the remote host name to the
+mode-compile-remote-execute-command,
+
+None is required for \"rsh\"."
+ :type 'string
+ :group 'compilation-remote)
+
+(defcustom mode-compile-remote-execute-set-command-arg ""
+ "Argument to set the command to be run remotely to the
+mode-compile-remote-execute-command.
+
+None is required for \"rsh\"."
+ :type 'string
+ :group 'compilation-remote)
+
+(defcustom mode-compile-remote-execute-set-username-arg "-l"
+ "Argument to set the username under which we will log on
+on the remote host, to give to mode-compile-remote-execute-command."
+ :type 'string
+ :group 'compilation-remote)
+
+(defcustom mode-compile-remote-execute-misc-args ""
+ "Misc additionnals arguments to give to the
+mode-compile-remote-execute-command."
+ :type 'string
+ :group 'compilation-remote)
+
+\f
+
+;; @@ c-mode compile variables ;;;
+(defgroup compile-c nil
+ "C Compilation options."
+ :group 'c
+ :group 'compilation-lang)
+
+(defcustom cc-compilers-list '( "gcc" "c89" "acc" "cc" )
+ "List of user's favourites C compilers in order of preferencies."
+ :type '(repeat (string :tag "C Compiler name"))
+ :group 'compile-c)
+
+(defcustom cc-companion-file-regexp "\\(_[Pp]\\)?\\.[pP]?h"
+ "Regexp to find associated .c file from a .h."
+ :type 'regexp
+ :group 'compile-c)
+
+(defcustom cc-default-compiler "cc"
+ "*Default C compiler to use when everything else fails.
+
+This could be any form evaluating to a string, so you could map it to
+a function asking you interactively to choose the compiler.
+
+example:
+ (defun my-choose-compiler()
+ (read-string \"C compiler: \"))
+ (setq cc-compilers-list '()
+ cc-default-compiler 'my-choose-compiler)"
+ :type '(choice string function)
+ :group 'compile-c)
+
+(defcustom cc-compiler-varenv "CC"
+ "Varenv indicating the C compiler to use."
+ :type 'string
+ :group 'compile-c)
+
+(defcustom cc-cflags-varenv "CFLAGS"
+ "Varenv indicating the C compiler flags to use."
+ :type 'string
+ :group 'compile-c)
+
+(defcustom cc-source-ext-list '( "c" )
+ "Extensions for C compileable source files."
+ :type '(repeat string)
+ :group 'compile-c)
+
+(defcustom cc-headers-ext-list '( "h" )
+ "Extensions for C headers source files."
+ :type '(repeat string)
+ :group 'compile-c)
+
+(defcustom cc-default-compiler-options "-g"
+ "*Default options to give to the C compiler.
+
+This could be any form evaluating to a string.
+See `mode-compile-choosen-compiler' variable."
+ :type '(choice
+ string
+ (sexp :tag "Form evaluating to a string"))
+ :group 'compile-c)
+
+(defcustom cc-source-file-ext-regexp "\\.c"
+ "Regexp to find, from it's name, if a C file is compileable."
+ :type 'string
+ :group 'compile-c)
+
+(defcustom cc-build-output-args t
+ "Build output-args for c-mode."
+ :type 'boolean
+ :group 'compile-c)
+
+(defcustom cc-object-file-ext "o"
+ "Extension of objects file (result of compilation)
+in c mode."
+ :type 'string
+ :group 'compile-c)
+
+\f
+
+;; @@ java-mode compile variables ;;;
+(defgroup compile-java nil
+ "Java compilation options."
+ :group 'compilation-lang)
+
+(defcustom java-compilers-list '( "javac" )
+ "List of user's favourites java compilers in order of preferencies."
+ :type '(repeat (string :tag "Java Compiler name"))
+ :group 'compile-java)
+
+(defcustom java-companion-file-regexp ""
+ "Regexp to find associated compileable Java companion file.
+
+This is useless in Java because there do not exists uncompileable files."
+ :type 'regexp
+ :group 'compile-java)
+
+(defcustom java-default-compiler "javac"
+ "*Default C compiler to use when everything else fails.
+
+This could be any form evaluating to a string, so you could map it to
+a function asking you interactively to choose the compiler.
+
+example:
+ (defun my-choose-compiler()
+ (read-string \"Java compiler: \"))
+ (setq java-default-compiler 'my-choose-compiler)."
+ :type '(choice string function)
+ :group 'compile-java)
+
+(defcustom java-compiler-varenv "JAVAC"
+ "Varenv indicating the C compiler to use."
+ :type 'string
+ :group 'compile-java)
+
+(defcustom java-cflags-varenv "JAVAC_FLAGS"
+ "Varenv indicating the C compiler flags to use."
+ :type 'string
+ :group 'compile-java)
+
+(defcustom java-source-ext-list '( "java" )
+ "Extensions for Java compileable source files."
+ :type '(repeat string)
+ :group 'compile-java)
+
+(defcustom java-headers-ext-list '( "java" )
+ "Extensions for Java source files."
+ :type '(repeat string)
+ :group 'compile-java)
+
+(defcustom java-default-compiler-options "-O"
+ "*Default options to give to the Java compiler.
+
+This could be any form evaluating to a string. See
+`mode-compile-choosen-compiler' variable."
+ :type '(choice
+ string
+ (sexp :tag "Form evaluating to a string"))
+ :group 'compile-java)
+
+(defcustom java-source-file-ext-regexp "\\.java"
+ "Regexp to find, from it's name, if a Java file is compileable."
+ :type 'regexp
+ :group 'compile-java)
+
+(defcustom java-build-output-args nil
+ "Dont build output-args for Java-mode."
+ :type 'boolean
+ :group 'compile-java)
+
+(defcustom java-object-file-ext "class"
+ "Extension of objects file (result of compilation)
+in java mode."
+ :type 'string
+ :group 'compile-java)
+
+\f
+
+;; @@ c++-mode compile variables ;;;
+(defgroup compile-c++ nil
+ "C++ compilation options"
+ :group 'compilation-lang)
+
+(defcustom c++-compilers-list '( "g++" "gcc" "CC" )
+ "List of user's favourites C++ compilers in order of preferencies."
+ :type '(repeat (string :tag "C++ Compiler name"))
+ :group 'compile-c++)
+
+(defcustom c++-companion-file-regexp "\\(_[Pp]\\)?\\.\\([pP]?[Hh][Hh]?\\|[Hh]\\+\\+?\\)"
+ "Regexp to find associated compileable C++ companion file
+from a header file."
+ :type 'regexp
+ :group 'compile-c++)
+
+(defcustom c++-default-compiler "CC"
+ "*Default C++ compiler to use when everything else fails..
+
+This could be any form evaluating to a string, so you could map it to
+a function asking you interactively to choose the compiler.
+
+example:
+ (defun my-choose-compiler()
+ (read-string \"C++ compiler: \"))
+ (setq c++-default-compiler 'my-choose-compiler)"
+ :type '(choice string function)
+ :group 'compile-c++)
+
+(defcustom c++-compiler-varenv "CXX"
+ "Varenv indicating the C++ compiler to use."
+ :type 'string
+ :group 'compile-c++)
+
+(defcustom c++-cflags-varenv "CXXFLAGS"
+ "Varenv indicating the C++ compiler flags to use."
+ :type 'string
+ :group 'compile-c++)
+
+(defcustom c++-source-ext-list '( "cc" "C" "CC" "cpp" "cxx" "c++" "c+" )
+ "Extensions for C++ compileable source files."
+ :type '(repeat string)
+ :group 'compile-c++)
+
+(defcustom c++-headers-ext-list '( "H" "hh" "HH" "h++" "h+" "h" "hpp" "hxx" )
+ "Extensions for C++ headers source files."
+ :type '(repeat string)
+ :group 'compile-c++)
+
+(defcustom c++-default-compiler-options "-g"
+ "*Default options to give to the C++ compiler.
+This could be any form evaluating to a string. See
+`mode-compile-choosen-compiler' variable."
+ :type '(choice
+ string
+ (sexp :tag "Form evaluating to a string"))
+ :group 'compile-c++)
+
+(defcustom c++-source-file-ext-regexp "\\.\\(cc\\|CC?\\|c\\+\\+?\\|cpp\\|cxx\\)"
+ "Regexp to find, from it's name, if a C++ file is compileable."
+ :type 'regexp
+ :group 'compile-c++)
+
+(defcustom c++-build-output-args t
+ "Build output-args for c++-mode."
+ :type 'boolean
+ :group 'compile-c++)
+
+(defcustom c++-object-file-ext "o"
+ "Extension of objects file (result of compilation)
+in c++ mode."
+ :type 'string
+ :group 'compile-c++)
+
+\f
+
+;; @@ ada-mode compile variables ;;;
+(defgroup compile-ada nil
+ "Ada compilation options"
+ :group 'compilation-lang)
+
+(defcustom ada-compilers-list
+ '( "gcc" "gnat" "ada" )
+ "List of user's favourites Ada compilers in order of preferencies."
+ :type '(repeat (string :tag "Ada Compiler name"))
+ :group 'compile-ada)
+
+(defcustom ada-companion-file-regexp ""
+ "Regexp to find associated compileable Ada companion file from a spec file.
+
+This is useless in Ada because there do not exists uncompileable files."
+ :type 'regexp
+ :group 'compile-ada)
+
+(defcustom ada-default-compiler "ada"
+ "*Default Ada compiler to use when everything else fails.
+
+This could be any form evaluating to a string, so you could map it to
+a function asking you interactively to choose the compiler.
+
+example:
+ (defun my-choose-compiler()
+ (read-string \"Ada compiler: \"))
+ (setq ada-default-compiler 'my-choose-compiler)"
+ :type '(choice string function)
+ :group 'compile-ada)
+
+(defcustom ada-compiler-varenv "ADA"
+ "Varenv indicating the Ada compiler to use."
+ :type 'string
+ :group 'compile-ada)
+
+(defcustom ada-aflags-varenv "AFLAGS"
+ "Varenv indicating the Ada compiler flags to use."
+ :type 'string
+ :group 'compile-ada)
+
+(defcustom ada-source-ext-list '( "ads" "adb" "ada" "a" )
+ "Extensions for Ada compileable source files."
+ :type '(repeat string)
+ :group 'compile-ada)
+
+(defcustom ada-headers-ext-list '( "ads" "ada" "a" )
+ "Extensions for Ada spec source files."
+ :type '(repeat string)
+ :group 'compile-ada)
+
+(defcustom ada-default-compiler-options "-g"
+ "*Default options to give to the Ada compiler.
+
+This could be any form evaluating to a string. See
+`mode-compile-choosen-compiler' variable."
+ :type '(choice
+ string
+ (sexp :tag "Form evaluating to a string"))
+ :group 'compile-ada)
+
+(defcustom ada-source-file-ext-regexp "\\.\\(ad[abs]\\|a\\)"
+ "Regexp to find, from it's name, if an Ada file is compileable.
+
+This is useless in Ada because there do not exists uncompileable files."
+ :type 'regexp
+ :group 'compile-ada)
+
+(defcustom ada-build-output-args t
+ "Build output-args for ada-mode."
+ :type 'boolean
+ :group 'compile-ada)
+
+(defcustom ada-object-file-ext "o"
+ "Extension of objects file (result of compilation)
+in ada mode."
+ :type 'string
+ :group 'compile-ada)
+
+\f
+
+;; @@ fortran-mode compile variables ;;;
+(defgroup compile-fortran nil
+ "Fortran compilation options"
+ :group 'compilation-lang)
+
+(defcustom f77-compilers-list '( "f77" "fc" )
+ "List of user's favourite Fortran compilers in order of preferencies."
+ :type '(repeat (string :tag "C Compiler name"))
+ :group 'compile-fortran)
+
+(defcustom f77-companion-file-regexp "\\(_[Pp]\\)?\\.[pP]?inc"
+ "Regexp to find associated .f file from a .inc."
+ :type 'regexp
+ :group 'compile-fortran)
+
+(defcustom f77-default-compiler "f77"
+ "*Default fortran compiler to use when everything else fails..
+
+This could be any form evaluating to a string, so you could map it to
+a function asking you interactively to choose the compiler.
+
+example:
+ (defun my-choose-compiler()
+ (read-string \"Fortran compiler: \"))
+ (setq f77-default-compiler 'my-choose-compiler)"
+ :type '(choice string function)
+ :group 'compile-fortran)
+
+(defcustom f77-compiler-varenv "F77"
+ "Varenv indicating the fortran compiler to use."
+ :type 'string
+ :group 'compile-fortran)
+
+(defcustom f77-cflags-varenv "FCOPTS"
+ "Varenv indicating the fortran compiler flags to use."
+ :type 'string
+ :group 'compile-fortran)
+
+(defcustom f77-source-ext-list '( "f" "F" "for" "For" )
+ "Extensions for fortran compileable source files."
+ :type '(repeat string)
+ :group 'compile-fortran)
+
+(defcustom f77-headers-ext-list '( "inc" "h")
+ "Extensions for fortran include files."
+ :type '(repeat string)
+ :group 'compile-fortran)
+
+(defcustom f77-default-compiler-options "-w66 -a"
+ "*Default options to give to the fortran compiler.
+
+This could be any form evaluating to a string. See
+`mode-compile-choosen-compiler' variable."
+ :type '(choice
+ string
+ (sexp :tag "Form evaluating to a string"))
+ :group 'compile-fortran)
+
+(defcustom f77-source-file-ext-regexp "\\.\\([Ff]\\|for\\)"
+ "Regexp to find, from it's name, if a fortran file is compileable."
+ :type 'regexp
+ :group 'compile-fortran)
+
+(defcustom f77-build-output-args t
+ "Build output-args for f77-mode."
+ :type 'boolean
+ :group 'compile-fortran)
+
+(defcustom f77-object-file-ext "o"
+ "Extension of objects file (result of compilation)
+in Fortran mode."
+ :type 'string
+ :group 'compile-fortran)
+
+\f
+
+;; @@ sh-mode compile variables ;;;
+(defgroup compile-sh nil
+ "Sh (Bourne Shell scripts) compilation options"
+ :group 'compilation-script)
+
+(defcustom sh-command "sh"
+ "Command to run sh scripts"
+ :type 'string
+ :group 'compile-sh)
+
+(defcustom sh-dbg-flags "-fvx"
+ "*Flags to give to sh for debugging a Bourne Shell script.
+
+The -f flag must always be present."
+ :type 'string
+ :group 'compile-sh)
+
+(defvar sh-compilation-error-regexp-alist nil
+ ;; I'd never seen a Bourne shell returning file+line where a syntax
+ ;; error occured.
+ "Alist that specifies how to match errors in sh output.
+
+See variable compilation-error-regexp-alist for more details.")
+\f
+
+;; @@ csh-mode compile variables ;;;
+(defgroup compile-csh nil
+ "Csh (C Shell) compilation options"
+ :group 'compilation-script)
+
+(defcustom csh-command "csh"
+ "Command to run csh scripts"
+ :type 'string
+ :group 'compile-csh)
+
+(defcustom csh-dbg-flags "-fVX"
+ "*Flags to give to csh for debugging a C Shell script.
+
+The -f flag must always be present."
+ :type 'string
+ :group 'compile-csh)
+
+(defvar csh-compilation-error-regexp-alist nil
+ ;; I'd never seen a C shell returning file+line where a syntax
+ ;; error occured.
+ "Alist that specifies how to match errors in csh output.
+
+See variable compilation-error-regexp-alist for more details.")
+\f
+
+;; @@ zsh-mode compile variables ;;;
+(defgroup compile-zsh nil
+ "Zsh (Z Shell scripts) compilation options"
+ :group 'compilation-script)
+
+(defcustom zsh-command "zsh"
+ "Command to run zsh scripts"
+ :type 'string
+ :group 'compile-zsh)
+
+(defcustom zsh-dbg-flags "-nCvx"
+ "*Flags to give to zsh for debugging a Z Shell script."
+ :type 'string
+ :group 'compile-zsh)
+
+(defvar zsh-compilation-error-regexp-alist nil
+ ;; I'd never seen a Z shell returning file+line where a syntax
+ ;; error occured.
+ "Alist that specifies how to match errors in csh output.
+
+See variable compilation-error-regexp-alist for more details.")
+\f
+
+;; @@ tcl-mode compile variables - JWH ;;;
+(defgroup compile-tcl nil
+ "Tcl compilation options"
+ :group 'compilation-script)
+
+(defcustom tcl-command "wish"
+ "Command to run tcl scripts"
+ :type 'string
+ :group 'compile-tcl)
+
+(defcustom tcl-dbg-flags ""
+ "*Flags to give to tcl -- none."
+ :type 'string
+ :group 'compile-tcl)
+
+(defvar tcl-compilation-error-regexp-alist
+ ;; TK (file "/directory-path/filename.tcl" line XY)
+ '(
+ ("file \"\\([^ ]+\\)\" line \\([0-9]+\\)[)]" 1 2)
+ )
+ "Alist that specifies how to match errors in tcl output.
+
+See variable compilation-error-regexp-alist for more details.")
+\f
+
+;; @@ python-mode compile variables - BM ;;;
+(defgroup compile-python nil
+ "Python compilation options"
+ :group 'compilation-script)
+
+(defcustom python-command "python"
+ "Command to run python scripts"
+ :type 'string
+ :group 'compile-python)
+
+(defcustom python-dbg-flags ""
+ "*Flags to give to python -- none."
+ :type 'string
+ :group 'compile-phthon)
+
+(defvar python-compilation-error-regexp-alist
+ ;; TK (file "/directory-path/filename.tcl" line XY in ZZZ)
+ '(
+ ("File \"\\([^ ]+\\)\", line \\([0-9]+\\).*" 1 2)
+ )
+ "Alist that specifies how to match errors in python output.
+
+See variable compilation-error-regexp-alist for more details.")
+\f
+
+;; @@ perl-mode compile variables ;;;
+(defgroup compile-perl nil
+ "Perl compilation options"
+ :group 'compilation-script)
+
+(defcustom perl-command "perl"
+ "Command to run perl."
+ :type 'string
+ :group 'compile-perl)
+
+(defcustom perl-dbg-flags "-w"
+ "*Flags to give to perl for debugging a Perl script."
+ :type 'string
+ :group 'compile-perl)
+
+(defvar perl-compilation-error-regexp-alist
+ ;; Contributed by Martin Jost
+ '(
+ ;; PERL 4
+ ("in file \\([^ ]+\\) at line \\([0-9]+\\).*" 1 2)
+ ;; PERL 5 Blubber at FILE line XY, <XY> line ab.
+ ("at \\([^ ]+\\) line \\([0-9]+\\)," 1 2)
+ ;; PERL 5 Blubber at FILE line XY.
+ ("at \\([^ ]+\\) line \\([0-9]+\\)." 1 2)
+ )
+ ;; This look like a paranoiac regexp: could anybody find a better one? (which WORK).
+ ;;'(("^[^\n]* \\(file\\|at\\) \\([^ \t\n]+\\) [^\n]*line \\([0-9]+\\)[\\.,]" 2 3))
+ "Alist that specifies how to match errors in perl output.
+
+See variable compilation-error-regexp-alist for more details.")
+\f
+
+;; @@ emacs lisp compile variables ;;;
+
+;;;###autoload
+(defcustom emacs-lisp-byte-compile-dir-interactive-p t
+ "*Non-nil means when byte-compiling a directory ask for each file
+needing to be recompiled or not."
+ :type 'boolean
+ :group 'compilation-elisp)
+(define-obsolete-variable-alias
+ 'mode-compile-byte-compile-dir-interactive-p
+ 'emacs-lisp-byte-compile-dir-interactive-p)
+
+(defcustom emacs-lisp-sources-regexp
+ (cond
+ ((boundp 'emacs-lisp-file-regexp)
+ emacs-lisp-file-regexp)
+ (t
+ "\\.el$"))
+ "Regexp to find emacs lisp sources files."
+ :type 'regexp
+ :group 'compilation-elisp)
+
+(defcustom emacs-lisp-bytecomp-ext "c"
+ "Extension added to byte-compiled emacs sources files."
+ :type 'string
+ :group 'compilation-elisp)
+\f
+
+;; @@ Misc declarations ;;;
+
+;;;###autoload
+(defconst mode-compile-version "2.28"
+ "Current version of mode-compile package.
+
+mode-compile.el,v 2.28 2003/04/01 13:52:47 boubaker Exp
+Please send bugs-fixes/contributions/comments to boubaker@cena.fr")
+
+(defconst mode-compile-help-address "heddy.Boubaker@cena.fr"
+ "E-Mail address of mode-compile maintainer.")
+\f
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; @ No user modifiable stuff below this line ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; Save old compile function. In case someone will bound
+;; mode-compile on 'compile.
+(or (fboundp 'mc--compile-sav)
+ (if (fboundp 'compile)
+ (progn
+ (fset 'mc--compile-sav (symbol-function 'compile))
+ (put 'compile 'compile-saved-on-mc--compile-sav t))
+ (error "`compile' function not known to be defined...")))
+
+;; @@ Internals variables and constants ;;;
+
+;; Mode specific
+(defvar mc--comp-lst nil) ; c-mode,c++-mode,ada-mode,fortran-mode
+(defvar mc--def-comp nil) ; itou
+(defvar mc--compfile-regexp nil) ; itou
+(defvar mc--comp-varenv nil) ; itou
+(defvar mc--comp-options nil) ; itou
+(defvar mc--cflags-varenv nil) ; itou
+(defvar mc--source-ext-lst nil) ; itou
+(defvar mc--head-ext-lst nil) ; itou
+(defvar mc--source-ext-regexp nil) ; itou
+(defvar mc--build-op-args nil) ; itou
+(defvar mc--outfile-ext nil) ; itou
+
+;; remote stuff
+(defvar mc--efs-path-list nil)
+(defvar mc--remote-host nil)
+(defvar mc--remote-host-history nil)
+(defvar mc--remote-username nil)
+(defvar mc--remote-command nil)
+(defvar mc--remote-pathname nil)
+
+;; Frames/Windows stuff
+(defvar mc--other-frame nil)
+(defvar mc--ws (or
+ (and (fboundp 'console-type) (console-type))
+ (and (fboundp 'device-type) (device-type))
+ window-system))
+
+(defvar mc--compile-command nil)
+;; Compile command used when no makefile has been found.
+;; This variable is buffer local to keep history for read-string.
+;; Unfortunately not a real history, keep only memory of
+;; the last compile command used.
+(make-variable-buffer-local 'mc--compile-command)
+
+(defvar mc--kill-compile nil)
+;; kill-compile command bound dynamically by `guess-compile'.
+(make-variable-buffer-local 'mc--kill-compile)
+
+(defvar mc--selected-makefile nil)
+(defvar mc--selected-makefile-history nil)
+;; User selected makefile among the list, to run make with.
+;; This variable is buffer local to keep history for completing-read
+;; Unfortunately not a real history, keep only memory of
+;; the last makefile used.
+(make-variable-buffer-local 'mc--selected-makefile)
+
+(defvar mc--selected-makerule nil)
+(defvar mc--selected-makerule-history nil)
+;; User selected make rule to rebuild.
+;; This variable is buffer local to keep history for completing-read
+;; Unfortunately not a real history, keep only memory of
+;; the last makerule used.
+(make-variable-buffer-local 'mc--selected-makerule)
+
+(defconst mc--find-C-main-regexp
+ "^[ \t]*\\(int\\|void\\)?[ \t\n]*main[ \t\n]*\(+" )
+;; Regexp to find the main() function in a C/C++ file
+
+(defconst mc--makefile-rules-regexp
+ "^\n*\\([^.$ \t#\n][^$ \t#\n:]*\\)[ \t]*:")
+;; Regexp to extract makefiles rules.
+;; But only those not containing references to $(VARIABLES)
+;; and not starting with `.'
+
+(defvar mc--makefile-rules nil)
+;; List of all rules extracted from makefile
+(make-variable-buffer-local 'mc--makefile-rules)
+
+(defvar mc--mkfl-buffer-tick nil)
+;; Tick counter for the buffer at the time of the rules extraction.
+(make-variable-buffer-local 'mc--mkfl-buffer-tick)
+
+(defvar mc--shell-args nil)
+;; Shell arguments for the script to debug.
+;; This variable is buffer local to keep history for read-string.
+;; Unfortunately not a real history, keep only memory of
+;; the last shell arguments used.
+(make-variable-buffer-local 'mc--shell-args)
+
+;; nil in GNU FSF Emacs, >= 0 in GNU Lucid Emacs/XEmacs
+(defconst mc--lucid-emacs-p (or (string-match "Lucid" emacs-version)
+ (string-match "XEmacs" emacs-version)))
+
+;; @@ Internals functions and macros ;;;
+
+(if (not (fboundp 'defsubst))
+ ;; Emacs 18
+ (fset 'defsubst (symbol-function 'defun)))
+
+(defun mc--compile (compile-command)
+ ;; Call compile with the compile command
+ ;; but append the remote-command before
+ (if (null mc--remote-command)
+ ;; local compile
+ (mc--compile-sav compile-command)
+ ;; remote compile
+ (let ((thisdir (expand-file-name (or default-directory "~"))))
+ (mc--compile-sav
+ (concat
+ ;; The command to lauch remote commands
+ mc--remote-command
+ ;; Change to this buffer directory ...
+ "'( cd " thisdir " ; "
+ ;; then run the compile command
+ compile-command " )'")))))
+
+(defsubst mc--msg (msg &rest args)
+ ;; Print MSG with ARGS and wait to let time to user
+ ;; to read the message in minibuffer.
+ (cond ((not mode-compile-expert-p)
+ (apply 'message (concat "mode-compile: " msg) args)
+ (sit-for mode-compile-reading-time))))
+
+(cond
+ ;; Check availaibles frames functions
+ ((fboundp 'make-frame)
+ ;; GNU Emacs
+ (fset 'mc--make-frame (symbol-function 'make-frame))
+ (fset 'mc--select-frame (symbol-function 'select-frame))
+ (fset 'mc--frame-live-p (symbol-function 'frame-live-p))
+ (fset 'mc--make-frame-visible (symbol-function 'make-frame-visible))
+ (fset 'mc--raise-frame (symbol-function 'raise-frame)))
+ ((fboundp 'make-screen)
+ ;; XEmacs
+ (fset 'mc--make-frame (symbol-function 'make-screen))
+ (fset 'mc--select-frame (symbol-function 'select-screen))
+ (fset 'mc--frame-live-p (symbol-function 'screen-live-p))
+ (fset 'mc--make-frame-visible (symbol-function 'make-screen-visible))
+ (fset 'mc--raise-frame (symbol-function 'raise-screen)))
+ ((fboundp 'new-screen)
+ ;; Lucid Emacs/obsolete
+ (fset 'mc--make-frame (symbol-function 'new-screen))
+ (fset 'mc--select-frame (symbol-function 'select-screen))
+ (fset 'mc--frame-live-p (symbol-function 'screen-live-p))
+ (fset 'mc--make-frame-visible (symbol-function 'make-screen-visible))
+ (fset 'mc--raise-frame (symbol-function 'raise-screen))))
+
+(defsubst mc--funcall (command &rest params)
+ ;; Run command with params in another frame or not:
+ ;; only if user ask for it and if window system is X
+ ;; (maybe test window-system is set will be enought?).
+ (cond ((and (eq mc--ws 'x)
+ mode-compile-other-frame-p)
+ ;; switch to another frame
+ (mc--msg "Switching to another frame to compile...")
+ (let ((buffer (current-buffer))
+ (win-attr (or mode-compile-frame-parameters-alist
+ mode-compile-default-frame-parameters))
+ (frame (cond ((fboundp 'mc--frame-live-p)
+ (if (mc--frame-live-p mc--other-frame)
+ mc--other-frame
+ nil))
+ (t
+ (mc--msg "Don't know how to check frame existence.")
+ nil))))
+ (cond ((fboundp 'mc--make-frame)
+ (mc--select-frame (or frame
+ (setq mc--other-frame
+ (mc--make-frame win-attr))))
+ ;; I really don't understand why the 3 following
+ ;; are necessary (raise-frame must be enought?).
+ (mc--make-frame-visible mc--other-frame)
+ (mc--raise-frame mc--other-frame)
+ (switch-to-buffer buffer))
+ (t
+ (mc--msg "Don't know how to create a new frame."))))))
+ ;; Just run the command with it's parameters
+ (apply command params))
+
+(defun mc--byte-compile-buffer()
+ (if (fboundp 'byte-compile-buffer) (byte-compile-buffer)
+ ;; No byte-compile-buffer
+ ;; Save current-buffer in a temporary file and byte-compile it.
+ (let ((tmp-file (concat (or (getenv "TMPDIR")
+ (concat mode-compile-dir-separator-char "tmp"))
+ mode-compile-dir-separator-char (make-temp-name "mc--"))))
+ (save-restriction
+ (widen)
+ (write-region (point-min) (point-max) tmp-file)
+ (condition-case err
+ (byte-compile-file tmp-file)
+ ;; handler
+ (error (mc--msg "Failing to byte-compile %s, #error %s"
+ (buffer-name) err)))
+ (delete-file tmp-file)
+ (let ((elc-file (concat tmp-file emacs-lisp-bytecomp-ext)))
+ (if (file-writable-p elc-file)
+ (condition-case err
+ (delete-file elc-file)
+ ;; handler
+ (error (mc--msg "Failing to delete %s, #error %s"
+ elc-file err)))))
+ (message nil))))) ; to clean minibuffer
+
+(fset 'mc--member
+ (if (fboundp 'member)
+ (symbol-function 'member)
+ ;; No member function
+ (function
+ (lambda (elt list)
+ (catch 'elt-is-member
+ (while list
+ (if (equal elt (car list))
+ (throw 'elt-is-member list))
+ (setq list (cdr list))))))))
+
+(fset 'mc--run-hooks
+ (if (fboundp 'run-hooks)
+ (symbol-function 'run-hooks)
+ ;; No run-hooks
+ (function
+ (lambda (hooklist)
+ (mapcar '(lambda (x)
+ ;; report an error if x not a function
+ (funcall x))
+ hooklist)))))
+
+(defsubst mc--read-string (prompt &optional initial-contents)
+ ;; On Lucid Emacs I use compile-history as 3rd argument but
+ ;; no history is possible with GNU emacs.
+ (if mc--lucid-emacs-p
+ (read-string prompt initial-contents 'compile-history)
+ (read-string prompt initial-contents)))
+
+(defmacro mc--eval (sym &optional arg)
+ ;; Evaluate symbol
+ (` (cond
+ ((and (symbolp (, sym))
+ (fboundp (, sym)))
+ (funcall (, sym) (, arg)))
+ (t
+ (eval (, sym))))))
+
+(defmacro mc--common-completion (alist)
+ ;; Return the greatest common string for all
+ ;; possible completions in alist.
+ (` (try-completion "" (, alist))))
+
+(defun mc--byte-recompile-files (files)
+ ;; Byte recompile all FILES which are older than their
+ ;; .elc files in the current directory
+ (let ((tmp-fl files))
+ (while (car-safe tmp-fl)
+ (let* ((el-file (car tmp-fl))
+ (elc-file (concat el-file emacs-lisp-bytecomp-ext)))
+ (mc--msg "Checking file %s ..." el-file)
+ ;; is el-file newer than elc-file (if exists)
+ (if (and (file-newer-than-file-p el-file elc-file)
+ (or (not emacs-lisp-byte-compile-dir-interactive-p)
+ (y-or-n-p (format "byte-recompile file %s? " el-file))))
+ (condition-case err
+ (byte-compile-file el-file)
+ ;; handler
+ (error (mc--msg "Failing to byte-compile %s, #error %s"
+ el-file err))))
+ (setq tmp-fl (cdr-safe tmp-fl))))
+ (mc--msg "All files processed")))
+
+(defun mc--which (file)
+ ;; Find an executable FILE in exec-path
+ (if (not (stringp file))
+ (error "mc--which: nil FILE arg"))
+ (if mc--lucid-emacs-p
+ ;; Some emacses don't have locate-file some have...
+ ;; Lucid have it in standard, some others (GNU) have it
+ ;; (add-on pkg) but the syntax is not always consistent...
+; (locate-file file exec-path nil 1)
+ (locate-file file exec-path mode-compile-exe-file-ext 1)
+ (let ((tmp-p-lst exec-path)
+ (found nil)
+ (file-found nil))
+ (while (and (car-safe tmp-p-lst)
+ (not (setq found
+ (file-executable-p
+ (setq file-found
+ (concat (car tmp-p-lst)
+ mode-compile-dir-separator-char
+ file
+ mode-compile-exe-file-ext))))))
+ (setq tmp-p-lst (cdr-safe tmp-p-lst)))
+ (if found file-found nil))))
+
+(defun mc--find-compiler ()
+ ;; Find user's favourite mode compiler
+ (mc--msg "Searching for your favourite %s compiler ..." mode-name)
+ (let ((tmp-comp-lst mc--comp-lst)
+ (compiler nil))
+ (or (getenv mc--comp-varenv)
+ (progn
+ (while (and tmp-comp-lst
+ (not (setq compiler
+ (mc--which (car tmp-comp-lst)))))
+ (setq tmp-comp-lst (cdr tmp-comp-lst)))
+ (file-name-nondirectory (or compiler (mc--eval mc--def-comp)))))))
+
+(defun mc--find-to-compile-file (&optional fname)
+ ;; Find the name of the file to compile.
+ (let ((file-name (or fname
+ (buffer-file-name)
+ (error "Compilation abort: Buffer %s has no filename."
+ (buffer-name))))
+ (assoc-file nil)
+ (found nil)
+ (pos 0))
+ (cond
+ ((string-match mc--source-ext-regexp file-name)
+ ;; buffer is a compileable file
+ (file-name-nondirectory file-name))
+
+ ((setq pos (string-match mc--compfile-regexp file-name))
+ ;; Buffer is not a compileable file, try to find associated
+ ;; compileable file.
+ (let ((tmp-ext-lst mc--source-ext-lst))
+ (mc--msg "Looking for a compileable companion file for %s..."
+ (file-name-nondirectory file-name))
+ (while (and tmp-ext-lst
+ (not (setq found
+ (file-readable-p
+ (setq assoc-file
+ (concat
+ (substring file-name 0 pos)
+ "." (car tmp-ext-lst)))))))
+ (setq tmp-ext-lst (cdr tmp-ext-lst))))
+ (if found
+ ;; A compileable companion source file found
+ (file-name-nondirectory assoc-file)
+ ;; No compileable companion source file found
+ (mc--msg "Couldn't find any compileable companion file for %s ..."
+ (file-name-nondirectory file-name))
+ nil))
+
+ (t
+ ;; Buffer has an unknown file extension
+ ;; Could I be more cool?
+ (error "Compilation abort: Don't know how to compile %s."
+ (file-name-nondirectory file-name))))))
+
+(defun mc--guess-compile-result-fname (infile)
+ ;; Try to guess if outfile will be an object file or
+ ;; an executable file by grepping for `main()' in INFILE.
+ (let ((base-fname
+ (substring infile 0
+ (string-match mc--source-ext-regexp infile))))
+ (save-excursion
+ ;; Create a temporary buffer containing infile contents
+ (set-buffer (find-file-noselect infile))
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ ;; Grep into tmp buffer for main function
+ ;; THIS WILL NOT WORK FOR PROGRAMMING LANGAGES
+ ;; WHICH ARE NOT C DIALECTS:
+ ;; In non C-ish modes I hope this regexp will never be found :-(
+ (if (re-search-forward mc--find-C-main-regexp (point-max) t)
+ (concat base-fname mode-compile-exe-file-ext)
+ (concat base-fname "." mc--outfile-ext)))))))
+
+(defun mc--build-output-args (infile)
+ ;; Build output arguments for compile command by scanning INFILE.
+ (mc--msg "Looking into %s to build compile command ..." infile)
+ (let ((out-file (mc--guess-compile-result-fname infile)))
+ (concat (if (string-match
+ (concat "\\." mc--outfile-ext "$")
+ out-file)
+ ;; outfile will be an object file
+ " -c "
+ ;; outfile will be an executable file
+ " ")
+ infile " -o " out-file )))
+
+(defun mc--set-remote-cmd (remote-host &optional username pathname)
+ ;; Check validity of remote-host or ask one to user
+ ;; Then build the first part of the remote command
+ (if (stringp remote-host)
+ ;; Arg is the remote host name
+ (let ((host-infos (assoc remote-host
+ mode-compile-remote-hosts-alist)))
+ (setq mc--remote-host
+ remote-host)
+ (setq mc--remote-username
+ (or username
+ (let ((usrnam (cdr host-infos)))
+ (if usrnam
+ (cond
+ ((stringp usrnam)
+ usrnam)
+ ((functionp usrnam)
+ ;; usrnam is a function call it with hostname arg
+ (funcall usrnam mc--remote-host))
+ (t
+ ;; What's that??
+ (mc--msg "%s is not a valid option using user-login-name" (pp-to-string usrnam))
+ (user-login-name)))
+ (user-login-name)))))
+ (setq mc--remote-pathname pathname)
+ ;; Add host to the user's list
+ (or host-infos
+ (setq mode-compile-remote-hosts-alist
+ (append (list (list remote-host))
+ mode-compile-remote-hosts-alist)))
+ ;; Prepare the command
+ (setq mc--remote-command
+ (concat
+ ;; "rsh host -l username"
+ mode-compile-remote-execute-command " "
+ mode-compile-remote-execute-set-host-arg " "
+ mc--remote-host " "
+ mode-compile-remote-execute-set-username-arg " "
+ mc--remote-username " "
+ mode-compile-remote-execute-misc-args " "
+ mode-compile-remote-execute-set-command-arg " "
+ )))
+ ;; Arg is: Ask to user then check
+ (let ((rhost (completing-read
+ "Remote host to compile to: "
+ mode-compile-remote-hosts-alist
+ nil nil
+ ;; Initial contents
+ (or mc--remote-host
+ (car-safe (car-safe mode-compile-remote-hosts-alist)))
+ mc--remote-host-history)))
+ (or (string= rhost "")
+ (mc--set-remote-cmd rhost)))))
+
+;(defmacro mc--makefile-test-p (makefile)
+; (` (and (, makefile)
+; (not (string-equal (, makefile) ""))
+; (not (file-directory-p (, makefile)))
+; (file-readable-p (, makefile)))))
+(defun mc--makefile-test-p (makefile)
+ (cond
+ ((or (not makefile)
+ (string-equal makefile ""))
+ (mc--msg "Empty makefile selection")
+ nil)
+ ((file-directory-p makefile)
+ (mc--msg "Makefile selection %s is a directory !!" makefile)
+ nil)
+ ((not (file-readable-p makefile))
+ (mc--msg "Makefile %s unreadable" makefile)
+ nil)
+ (t)))
+
+
+(if (not (fboundp 'buffer-modified-tick))
+ (fset 'buffer-modified-tick
+ ;; allways indicate modified
+ (function
+ (lambda()
+ (if mc--mkfl-buffer-tick
+ (+ mc--mkfl-buffer-tick 1)
+ 1)))))
+
+(defun mc--get-makefile-rules (makefile)
+ ;; Try to find if makefile's buffer has been modified
+ ;; since last rule extraction
+ (if (or (not mc--mkfl-buffer-tick)
+ (not (equal mc--mkfl-buffer-tick
+ (buffer-modified-tick))))
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (setq mc--mkfl-buffer-tick (buffer-modified-tick))
+ (setq mc--makefile-rules nil)
+ (mc--msg "Extracting rules from %s ..." makefile)
+ ;; Grep into tmp buffer for makefile rules
+ (while (re-search-forward mc--makefile-rules-regexp nil t)
+ (let ((rule (buffer-substring
+ (match-beginning 1)
+ (match-end 1))))
+ ;; add rule to list if it don't match the ignore regexp
+ ;; and if not allready in rules list.
+ (if (and
+ (or (not mode-compile-ignore-makerule-regexp)
+ (not (string-match
+ mode-compile-ignore-makerule-regexp
+ rule)))
+ (not (mc--member rule mc--makefile-rules)))
+ (setq mc--makefile-rules
+ (append mc--makefile-rules
+ (list rule))))))))
+ (mc--msg "Rules had already been extracted from %s ..." makefile))
+ ;; Always add an empty rule to allow `default' choice.
+ (append mc--makefile-rules '([])))
+
+(defun mc--makerule-completion (alist outfile &optional pref)
+ ;; Return the makerule completion according to the prefered
+ ;; default makerule
+ (let ((preference (or pref
+ mode-compile-prefered-default-makerule)))
+ (mc--msg "Prefered makerule choice is '%s" preference)
+ (cond
+ ((eq preference 'none)
+ ;; Just show max common completion string to user
+ (or (mc--common-completion alist) ""))
+
+ ((eq preference 'all)
+ ;; Find the all rule or 'none
+ (if (assoc "all" alist) "all"
+ (mc--makerule-completion alist outfile 'none)))
+
+ ((eq preference 'file)
+ ;; The out file is prefered or 'none
+ (or outfile (mc--makerule-completion alist outfile 'none)))
+
+ ((eq preference 'default)
+ ;; Find the default rule or ""
+ (if (assoc "default" alist) "default" ""))
+
+ (t
+ ;; Invalid preference return 'none
+ (mc--msg "Invalid `mode-compile-prefered-default-makerule': '%s"
+ mode-compile-prefered-default-makerule)
+ (mc--makerule-completion alist outfile 'none)))))
+
+(defun mc--choose-makefile-rule (makefile &optional outfile)
+ ;; Choose the makefile rule and set it makefile local
+ (save-excursion
+ ;; Switch to makefile buffer
+ (set-buffer (find-file-noselect makefile))
+ (setq mc--selected-makerule
+ ;; Add the name of the out file to the makefile
+ ;; rules list if not allready in.
+ (let* ((mk-rules-alist (mc--get-makefile-rules makefile))
+ (choices (mapcar '(lambda (x) (list x))
+ (if (or (not outfile)
+ (mc--member outfile
+ mk-rules-alist))
+ mk-rules-alist
+ (append mk-rules-alist
+ (list outfile))))))
+ (completing-read
+ (if mode-compile-expert-p
+ "Make rule: "
+ "Using `make', enter rule to rebuild ([TAB] to complete): ")
+ choices
+ nil nil
+ ;; initial contents
+ (or mc--selected-makerule
+ (mc--makerule-completion choices outfile
+ (if outfile 'file)))
+ mc--selected-makerule-history
+ )))))
+
+(defmacro mc--cleanup-makefile-list (makefile-list)
+ ;; Remove unusable and/or backups makefiles from list
+ (` (let ((newlist))
+ (mapcar
+ '(lambda (x)
+ (if (and (mc--makefile-test-p x)
+ (or (not mode-compile-ignore-makefile-backups)
+ (not (string-match
+ mode-compile-makefile-backups-regexp
+ x))))
+ (setq newlist (cons x newlist))
+ (mc--msg "Removing makefile \"%s\" from completion list"
+ x)))
+ (, makefile-list))
+ newlist)))
+
+(defun mc--makefile-to-use (&optional directory)
+ ;; Find the makefile to use in the current directory
+ (let ((makefile-list (mc--cleanup-makefile-list
+ (directory-files
+ ;; I do not use the 5th parameter in Lucid Emacs
+ ;; to be compatible with GNU Emacs which accept
+ ;; only 4 parameters - no NOSORT -.
+ (or directory default-directory)
+ nil mode-compile-makefile-regexp t))))
+ (cond
+ ((not makefile-list)
+ ;; No makefile found
+ nil)
+
+ ((and (not (cdr-safe makefile-list))
+ (mc--makefile-test-p (car makefile-list)))
+ ;; Only one valid makefile
+ (car makefile-list))
+
+ (t
+ ;; Many makefiles in directory ask user to select one
+ (let ((choices (mapcar
+ '(lambda (x) (list x))
+ makefile-list))
+ (makefile nil))
+ (while
+ ;; While the makefile do not pass the test.
+ (not (mc--makefile-test-p
+ (setq makefile
+ (completing-read
+ (if mode-compile-expert-p
+ "Makefile: "
+ "Using `make', select makefile to use ([TAB] to complete): ")
+ choices
+ nil t
+ ;; initial contents
+ (or mc--selected-makefile
+ (mc--common-completion choices))
+ mc--selected-makefile-history
+ )))))
+ makefile)))))
+
+(defun mc--set-command (&optional file)
+ ;; Return a compilation command, built according to the existence
+ ;; of a makefile or not, to compile FILE .
+ (setq completion-ignore-case nil) ; let completion be case sensitive
+ (let ((to-compile-fname (or file (mc--find-to-compile-file))))
+ (if (setq mc--selected-makefile (mc--makefile-to-use))
+ (progn
+ ;; A makefile found in the directory:
+ ;; using make to compile
+ (let ((out-fname (if to-compile-fname
+ (mc--guess-compile-result-fname
+ to-compile-fname)
+ nil)))
+ ;; build make command by asking rule to user
+ (concat mode-compile-make-program " "
+ (or (mc--eval mode-compile-make-options) "")
+ " -f " mc--selected-makefile " "
+ (mc--choose-makefile-rule
+ mc--selected-makefile out-fname))))
+ ;; else
+ ;; No makefile: build compile command asking for confirmation to user.
+ ;; Should this be replaced by the creation of a makefile (and then
+ ;; running it) as rms proposed me?
+ (or mc--compile-command
+ (setq mc--compile-command
+ (concat (setq mode-compile-choosen-compiler
+ (mc--find-compiler)) " "
+ (or (getenv mc--cflags-varenv)
+ (mc--eval mc--comp-options))
+ (if to-compile-fname
+ (if mc--build-op-args
+ (mc--build-output-args to-compile-fname)
+ (concat " " to-compile-fname)
+ )
+ " "))))
+ (if (not mode-compile-never-edit-command-p)
+ (setq mc--compile-command
+ (mc--read-string
+ (if mode-compile-expert-p
+ "Compile command: "
+ (if to-compile-fname
+ (format "Edit command to compile %s: "
+ to-compile-fname)
+ "Edit compile command: " ))
+ mc--compile-command))
+ mc--compile-command))))
+
+(defun mc--shell-compile (shell dbgflags &optional errors-regexp-alist)
+ ;; Run SHELL with debug flags DBGFLAGS on current-buffer
+ (let* ((shcmd (or (mc--which shell)
+ (error "Compilation abort: command %s not found" shell)))
+ (shfile (or mc--remote-pathname (buffer-file-name)
+ (error "Compilation abort: Buffer %s has no filename"
+ (buffer-name))))
+ (run-cmd (concat shcmd " " dbgflags " " shfile " "
+ (setq mc--shell-args
+ (read-string (if mode-compile-expert-p
+ "Argv: "
+ (format "Arguments to %s %s script: "
+ shfile shell))
+ mc--shell-args)))))
+ ;; Modify compilation-error-regexp-alist if needed
+ (if errors-regexp-alist
+ (progn
+ ;; Set compilation-error-regexp-alist from compile
+ (or (listp errors-regexp-alist)
+ (error "Compilation abort: In mc--shell-compile errors-regexp-alist not a list."))
+ ;; Add new regexp alist to compilation-error-regexp-alist
+ (mapcar '(lambda(x)
+ (if (mc--member x compilation-error-regexp-alist) nil
+ (setq compilation-error-regexp-alist
+ (append (list x)
+ compilation-error-regexp-alist))))
+ errors-regexp-alist)))
+ ;; Run compile with run-cmd
+ (mc--compile run-cmd)))
+
+(defmacro mc--assq-get-fcomp (asq)
+ ;; Return compile-function associated to ASQ
+ (` (let* ((mode (cdr (, asq)))
+ (massq (assq mode mode-compile-modes-alist)))
+ (if massq (car-safe (cdr massq))))))
+
+(defmacro mc--assq-get-fkill (asq)
+ ;; Return kill-compile-function associated to ASQ
+ (` (let* ((mode (cdr (, asq)))
+ (massq (assq mode mode-compile-modes-alist)))
+ (if massq (car-safe (cdr-safe (cdr massq)))))))
+
+(defun mc--lookin-for-shell ()
+ ;; Look into current-buffer to see if it is a shell script
+ ;; and return function to compile it or nil.
+ (mc--msg "Looking if buffer %s is a shell script..." (buffer-name))
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (if (looking-at "#![ \t]*/\\([^ \t\n]+/\\)\\([^ \t\n]+\\)")
+ (let* ((shell-name (buffer-substring (match-beginning 2)
+ (match-end 2)))
+ (shell-assq (assoc shell-name mode-compile-shell-alist)))
+ (if shell-assq
+ (progn
+ (mc--msg "Buffer is a %s script" shell-name)
+ (setq mc--kill-compile (mc--assq-get-fkill shell-assq))
+ (mc--assq-get-fcomp shell-assq))
+ nil))))))
+
+(defun mc--lookat-name ()
+ ;; Lookat buffer file name to see if it can return a function
+ ;; to compile it or nil.
+ (mc--msg "Trying to guess compile command from buffer %s file name..."
+ (buffer-name))
+ (let ((fname (buffer-file-name)))
+ (if (not fname) nil
+ ;; try regexp from mode-compile-filename-regexp-alist
+ (let ((tmp-al mode-compile-filename-regexp-alist)
+ (found nil))
+ (while (and tmp-al (car tmp-al) (not found))
+ ;; evaluate to string
+ (let ((regxp (mc--eval (car (car tmp-al)))))
+ (if (string-match regxp fname)
+ (setq found (car tmp-al)))
+ (setq tmp-al (cdr tmp-al))))
+ (if (not found)
+ nil
+ (mc--msg "File %s matches regexp %s" fname (car found))
+ (setq mc--kill-compile (mc--assq-get-fkill found))
+ (mc--assq-get-fcomp found))))))
+\f
+
+;; @ mode specific functions ;;;
+
+(defun cc-compile ()
+ "Run `compile' with a dynamically built command for `c-mode'.
+
+The command is built depending of the existence of a makefile (which could
+be specified by changing value of variable mode-compile-makefile-regexp) in
+the current directory or not.
+If no makefile is found try to run a C compiler on the file or it's companion.
+
+See also variables:
+ -- cc-compilers-list
+ -- cc-default-compiler
+ -- cc-companion-file-regexp
+ -- cc-compiler-varenv
+ -- cc-cflags-varenv
+ -- cc-source-ext-list
+ -- cc-headers-ext-list
+ -- cc-source-file-ext-regexp"
+ (setq
+ mc--comp-lst cc-compilers-list
+ mc--def-comp cc-default-compiler
+ mc--compfile-regexp cc-companion-file-regexp
+ mc--comp-varenv cc-compiler-varenv
+ mc--comp-options cc-default-compiler-options
+ mc--cflags-varenv cc-cflags-varenv
+ mc--source-ext-lst cc-source-ext-list
+ mc--head-ext-lst cc-headers-ext-list
+ mc--source-ext-regexp cc-source-file-ext-regexp
+ mc--build-op-args cc-build-output-args
+ mc--outfile-ext cc-object-file-ext
+ )
+ (mc--compile (mc--set-command)))
+
+(defun java-compile ()
+ "Run `compile' with a dynamically built command for `java-mode'.
+
+The command is built depending of the existence of a makefile (which could
+be specified by changing value of variable mode-compile-makefile-regexp) in
+the current directory or not.
+If no makefile is found try to run a Java compiler on the file or it's
+companion.
+
+See also variables:
+ -- java-compilers-list
+ -- java-default-compiler
+ -- java-companion-file-regexp
+ -- java-compiler-varenv
+ -- java-cflags-varenv
+ -- java-source-ext-list
+ -- java-headers-ext-list
+ -- java-source-file-ext-regexp"
+ (setq
+ mc--comp-lst java-compilers-list
+ mc--def-comp java-default-compiler
+ mc--compfile-regexp java-companion-file-regexp
+ mc--comp-varenv java-compiler-varenv
+ mc--comp-options java-default-compiler-options
+ mc--cflags-varenv java-cflags-varenv
+ mc--source-ext-lst java-source-ext-list
+ mc--head-ext-lst java-headers-ext-list
+ mc--source-ext-regexp java-source-file-ext-regexp
+ mc--build-op-args java-build-output-args
+ mc--outfile-ext java-object-file-ext
+ )
+ (mc--compile (mc--set-command)))
+
+(defun c++-compile ()
+ "Run `compile' with a dynamically built command for `c++-mode'.
+
+The command is built depending of the existence of a makefile (which could
+be specified by changing value of variable mode-compile-makefile-regexp) in
+the current directory or not.
+If no makefile is found try to run a C++ compiler on the file or it's companion.
+
+See also variables:
+ -- c++-compilers-list
+ -- c++-default-compiler
+ -- c++-companion-file-regexp
+ -- c++-compiler-varenv
+ -- c++-cflags-varenv
+ -- c++-source-ext-list
+ -- c++-headers-ext-list
+ -- c++-source-file-ext-regexp"
+ (setq
+ mc--comp-lst c++-compilers-list
+ mc--def-comp c++-default-compiler
+ mc--compfile-regexp c++-companion-file-regexp
+ mc--comp-varenv c++-compiler-varenv
+ mc--comp-options c++-default-compiler-options
+ mc--cflags-varenv c++-cflags-varenv
+ mc--source-ext-lst c++-source-ext-list
+ mc--head-ext-lst c++-headers-ext-list
+ mc--source-ext-regexp c++-source-file-ext-regexp
+ mc--build-op-args c++-build-output-args
+ mc--outfile-ext c++-object-file-ext
+ )
+ (mc--compile (mc--set-command)))
+
+
+(defun ada-compile ()
+ "Run `compile' with a dynamically built command for `ada-mode'.
+
+The command is built depending of the existence of a makefile (which could
+be specified by changing value of variable mode-compile-makefile-regexp) in
+the current directory or not.
+If no makefile is found try to run an Ada compiler on the file.
+
+See also variables:
+ -- ada-compilers-list
+ -- ada-default-compiler
+ -- ada-companion-file-regexp
+ -- ada-compiler-varenv
+ -- ada-aflags-varenv
+ -- ada-source-ext-list
+ -- ada-headers-ext-list
+ -- ada-source-file-ext-regexp)"
+ (setq
+ mc--comp-lst ada-compilers-list
+ mc--def-comp ada-default-compiler
+ mc--compfile-regexp ada-companion-file-regexp
+ mc--comp-varenv ada-compiler-varenv
+ mc--comp-options ada-default-compiler-options
+ mc--cflags-varenv ada-aflags-varenv
+ mc--source-ext-lst ada-source-ext-list
+ mc--head-ext-lst ada-headers-ext-list
+ mc--source-ext-regexp ada-source-file-ext-regexp
+ mc--build-op-args ada-build-output-args
+ mc--outfile-ext ada-object-file-ext
+ )
+ (mc--compile (mc--set-command)))
+
+
+(defun f77-compile ()
+ "Run `compile' with a dynamically built command for `fortran-mode'.
+
+The command is built depending of the existence of a makefile (which could
+be specified by changing value of variable mode-compile-makefile-regexp) in
+the current directory or not.
+If no makefile is found try to run a Fortran compiler on the file or it's companion..
+
+See also variables:
+ -- f77-compilers-list
+ -- f77-default-compiler
+ -- f77-companion-file-regexp
+ -- f77-compiler-varenv
+ -- f77-cflags-varenv
+ -- f77-source-ext-list
+ -- f77-headers-ext-list
+ -- f77-source-file-ext-regexp)"
+ (setq
+ mc--comp-lst f77-compilers-list
+ mc--def-comp f77-default-compiler
+ mc--compfile-regexp f77-companion-file-regexp
+ mc--comp-varenv f77-compiler-varenv
+ mc--cflags-varenv f77-cflags-varenv
+ mc--comp-options f77-default-compiler-options
+ mc--source-ext-lst f77-source-ext-list
+ mc--head-ext-lst f77-headers-ext-list
+ mc--source-ext-regexp f77-source-file-ext-regexp
+ mc--build-op-args f77-build-output-args
+ mc--outfile-ext f77-object-file-ext
+ )
+ (mc--compile (mc--set-command)))
+
+
+(defun elisp-compile ()
+ "Run `byte-compile' on the current Emacs lisp buffer.
+For `emacs-lisp-mode' and `lisp-interaction-mode'.
+
+Produce a `.elc' file if possible or `byte-compile' only the buffer."
+ (let ((comp-file (or (buffer-file-name) "")))
+ (if (string-match emacs-lisp-sources-regexp comp-file)
+ (progn
+ (mc--msg "Byte compiling file %s ..." comp-file)
+ (byte-compile-file comp-file))
+ (mc--msg "Byte compiling buffer %s #No .elc produced ..." (buffer-name))
+ (mc--byte-compile-buffer))))
+
+
+(defun makefile-compile (&optional makefile)
+ "Run `make' on the current-buffer (`makefile-mode').
+
+The user is prompted for a selection of make rules to build."
+ (let ((mkfile (or makefile (buffer-file-name)
+ (error
+ "Compilation abort: buffer %s has no file name"
+ (buffer-name)))))
+ (setq mc--selected-makefile mkfile)
+ (setq mc--compile-command
+ (concat mode-compile-make-program " "
+ (or (mc--eval mode-compile-make-options) "")
+ " -f " mkfile " "
+ (mc--choose-makefile-rule mkfile))))
+ (mc--compile mc--compile-command))
+
+
+(defun dired-compile ()
+ "Run `make' if a Makefile is present in current directory (`dired-mode').
+
+The user is prompted for a selection of a makefile to choose if many
+matching `mode-compile-makefile-regexp' are present in the directory and
+for the make rules to build. If directory contain no makefile the function
+try to find if there are some un-byte-compiled .el files and recompile them
+if needed.
+Ask for the complete `compile-command' if no makefile and no .el files found."
+ (let ((makefile (mc--makefile-to-use)))
+ (if makefile
+ ;; Makefile exists compile with it
+ (makefile-compile makefile)
+ ;; No makefile found look for some .el files
+ (mc--msg "No makefile found, looking for .el files ...")
+ (let ((el-files (directory-files
+ default-directory nil emacs-lisp-sources-regexp)))
+ (if el-files
+ ;; Some .el files found byte-recompile them
+ (mc--byte-recompile-files el-files)
+ ;; No .el files ask compile command to user
+ (mc--msg "No .el files found in directory %s" default-directory)
+ (default-compile))))))
+
+
+(defun sh-compile ()
+ "Run `sh-command' (Bourne Shell) with `sh-dbg-flags' on current-buffer (`sh-mode').
+
+User is prompted for arguments to run his sh program with.
+If you want to step throught errors set the variable `sh-compilation-error-regexp-alist'
+to a value understandable by compile's `next-error'.
+See variables compilation-error-regexp-alist or sh-compilation-error-regexp-alist."
+ (mc--shell-compile sh-command sh-dbg-flags sh-compilation-error-regexp-alist))
+
+
+(defun csh-compile ()
+ "Run `csh-command' (C Shell) with `csh-dbg-flags' on current-buffer (`csh-mode').
+
+User is prompted for arguments to run his csh program with.
+If you want to step throught errors set the variable `csh-compilation-error-regexp-alist'
+to a value understandable by compile's `next-error'.
+See variables compilation-error-regexp-alist or csh-compilation-error-regexp-alist."
+ (mc--shell-compile csh-command csh-dbg-flags csh-compilation-error-regexp-alist))
+
+
+(defun zsh-compile ()
+ "Run `zsh-command' (Z Shell) with `zsh-dbg-flags' on current-buffer (`zsh-mode').
+
+User is prompted for arguments to run his zsh program with.
+If you want to step throught errors set the variable `zsh-compilation-error-regexp-alist'
+to a value understandable by compile's `next-error'.
+See variables compilation-error-regexp-alist or zsh-compilation-error-regexp-alist."
+ (mc--shell-compile zsh-command zsh-dbg-flags zsh-compilation-error-regexp-alist))
+
+
+(defun perl-compile ()
+ "Run Perl with `perl-dbg-flags' on current-buffer (`perl-mode').
+
+User is prompted for arguments to run his perl program with.
+If you want to step throught errors set the variable `perl-compilation-error-regexp-alist'
+to a value understandable by compile's `next-error'.
+See variables compilation-error-regexp-alist or perl-compilation-error-regexp-alist."
+ (mc--shell-compile perl-command perl-dbg-flags perl-compilation-error-regexp-alist))
+
+
+(defun tcl-compile ()
+ ;; JWH
+ "Run `tcl-command' with `tcl-dbg-flags' on current-buffer (`tcl-mode').
+
+User is prompted for arguments to run his Tcl/Tk program with.
+If you want to step throught errors set the variable `tcl-compilation-error-regexp-alist'
+to a value understandable by compile's `next-error'.
+See variables compilation-error-regexp-alist or tcl-compilation-error-regexp-alist."
+ (mc--shell-compile tcl-command tcl-dbg-flags tcl-compilation-error-regexp-alist))
+
+
+(defun python-compile ()
+ ;; BM
+ "Run `python-command' with `python-dbg-flags' on current-buffer (`python-mode').
+
+User is prompted for arguments to run his Python program with.
+If you want to step throught errors set the variable `python-compilation-error-regexp-alist'
+to a value understandable by compile's `next-error'.
+See variables compilation-error-regexp-alist or python-compilation-error-regexp-alist."
+ (mc--shell-compile python-command python-dbg-flags python-compilation-error-regexp-alist))
+
+
+(defun default-compile ()
+ "Default function invoked by `mode-compile' (\\[mode-compile])
+when everything else failed.
+
+Ask to user to edit `compile-command' and run `compile' (\\[compile]) with it."
+ (setq mc--compile-command
+ (mc--read-string
+ (if mode-compile-expert-p
+ "Compile command: "
+ (format "Edit command to compile %s : " (buffer-name)))
+ (or mc--compile-command compile-command)))
+ (mc--compile mc--compile-command))
+
+(defvar mc--makefile) ;; Just to avoid compiler warning
+(defun guess-compile ()
+ "Try to guess how to compile current-buffer.
+
+When the compile command could not be extrapolated from major-mode this function
+is called which try to guess from number of parameters which command to build.
+The steps to guess which command to use to compile are:
+ 1st : Look into the file to check if it is a shell script
+ See variable mode-compile-shell-alist
+ 2nd : Try to guess from the file name
+ See variable mode-compile-filename-regexp-alist
+ 3rd : Look for a makefile in the current directory
+ See variable mode-compile-makefile-regexp
+ Last: Give up and ask user for the command to use
+ See function default-compile"
+ (mc--msg "Trying to guess how to compile buffer %s ..." (buffer-name))
+ (let ((mc--makefile))
+ (funcall
+ (or
+ ;; step 1
+ (mc--lookin-for-shell)
+ ;; step 2
+ (mc--lookat-name)
+ ;; step 3
+ (progn
+ (mc--msg "Looking for a makefile in current directory...")
+ (if (setq mc--makefile (mc--makefile-to-use
+ (and (buffer-file-name)
+ (file-name-directory (buffer-file-name)))))
+ (progn
+ (setq mc--kill-compile 'kill-compilation)
+ ;; Byte-compiling says `makefile' is not referenced.
+ '(lambda () (makefile-compile mc--makefile)))))
+ ;; step 4
+ (progn
+ (mc--msg "Don't know how to compile %s, giving up..."
+ (buffer-name))
+ (setq mc--kill-compile 'kill-compilation)
+ 'default-compile)))))
+\f
+
+;; @ user accessible/exported function ;;;
+
+;; get reporter-submit-bug-report when byte-compiling
+(and (fboundp 'eval-when-compile)
+ (eval-when-compile (require 'reporter)))
+
+;;;###autoload
+(defun mode-compile-submit-bug-report ()
+ "*Submit via mail a bug report on mode-compile v2.27."
+ (interactive)
+ (and
+ (y-or-n-p "Do you REALLY want to submit a report on mode-compile? ")
+ (require 'reporter)
+ (reporter-submit-bug-report
+ mode-compile-help-address
+ (concat "mode-compile " mode-compile-version)
+ (list
+ ;; Interesting mode-compile variables
+ 'mode-compile-modes-alist
+ 'mode-compile-filename-regexp-alist
+ 'mode-compile-shell-alist
+ 'mode-compile-makefile-regexp
+ 'mode-compile-make-program
+ 'mode-compile-default-make-options
+ 'mode-compile-make-options
+ 'mode-compile-reading-time
+ 'mode-compile-expert-p
+ 'mode-compile-never-edit-command-p
+ 'mode-compile-save-all-p
+ 'mode-compile-always-save-buffer-p
+ 'mode-compile-before-compile-hook
+ 'mode-compile-after-compile-hook
+ 'mode-compile-before-kill-hook
+ 'mode-compile-after-kill-hook
+ 'mode-compile-other-frame-p
+ 'mode-compile-other-frame-name
+ 'mode-compile-frame-parameters-alist
+ 'mode-compile-prefered-default-makerule
+ 'emacs-lisp-byte-compile-dir-interactive-p
+ ;; others variables
+ 'features
+ 'compilation-error-regexp-alist
+ 'compile-command
+ )
+ nil
+ nil
+ "Dear Heddy,")))
+\f
+
+;;;###autoload
+(defun mode-compile (&optional remote-host)
+ "*Compile the file in the current buffer with a dynamically built command.
+
+The command is built according to the current major mode the function
+was invoked from.
+
+Running this command preceded by universal-argument (\\[universal-argument])
+allows remote compilation, the user is prompted for a host name to run the
+compilation command on.
+
+Currently know how to compile in:
+ `c-mode' , -- function cc-compile.
+ `java-mode' , -- function java-compile.
+ `c++-mode', -- function c++-compile.
+ `ada-mode', -- function ada-compile.
+ `fortran-mode', -- function f77-compile.
+ `emacs-lisp-mode' -- function elisp-compile.
+ `lisp-interaction-mode' -- function elisp-compile.
+ `makefile-mode' -- function makefile-compile.
+ `dired-mode' -- function dired-compile.
+ `sh-mode' -- function sh-compile.
+ `csh-mode' -- function csh-compile.
+ `zsh-mode' -- function zsh-compile.
+ `perl-mode' -- function perl-compile.
+ `cperl-mode' -- function perl-compile.
+ `tcl-mode' -- function tcl-compile.
+ `python-mode' -- function python-compile.
+ `fundamental-mode' -- function guess-compile.
+ `text-mode' -- function guess-compile.
+ `indented-text-mode' -- function guess-compile.
+ `compilation-mode' -- function default-compile.
+ The function `guess-compile' is called when mode is unknown.
+
+The variable `mode-compile-modes-alist' contain description of known
+modes. The hooks variables `mode-compile-before-compile-hook' and
+`mode-compile-after-compile-hook' are run just before and after
+invoking the compile command of the mode.
+
+Use the command `mode-compile-kill' (\\[mode-compile-kill]) to abort a
+running compilation.
+
+Bound on \\[mode-compile]."
+ (interactive "P")
+ ;; reinit
+ (setq
+ mc--efs-path-list nil
+ mc--remote-command nil)
+ (if remote-host
+ ;; Remote compilation asked
+ ;; prepare remote command
+ (mc--set-remote-cmd remote-host)
+ ;; Not asked but check buffer-file-name to see
+ ;; if it is not an efs file
+ (setq mc--efs-path-list (and (fboundp 'efs-ftp-path)
+ (buffer-file-name)
+ (efs-ftp-path (buffer-file-name))))
+ (and mc--efs-path-list (mc--set-remote-cmd
+ (car mc--efs-path-list)
+ (nth 1 mc--efs-path-list)
+ (nth 2 mc--efs-path-list))))
+ (if (and mode-compile-always-save-buffer-p
+ (buffer-file-name))
+ ;; save-buffer allready check if buffer had been modified
+ (save-buffer))
+ (if mode-compile-save-all-p (save-some-buffers t))
+ ;; Check if compile-command set as local variable
+ (if (and
+ (boundp 'compile-command)
+ (local-variable-p 'compile-command (current-buffer))
+ compile-command ; not null
+ (if mc--compile-command
+ (equal compile-command mc--compile-command)
+ t)
+ )
+ ;; Just ask user and go
+ (progn
+ (mc--run-hooks 'mode-compile-before-compile-hook)
+ (default-compile)
+ (mc--run-hooks 'mode-compile-after-compile-hook)
+ )
+ ;; Here is the real work
+ (let ((mode-elem (assq major-mode mode-compile-modes-alist)))
+ (if mode-elem
+ ;; known mode
+ (progn
+ (mc--msg (substitute-command-keys
+ "Compiling in %s mode ... \\[mode-compile-kill] to kill.")
+ mode-name)
+ (mc--run-hooks 'mode-compile-before-compile-hook)
+ ;; mc--funcall can launch the compilation
+ ;; in another frame.
+ (mc--funcall (car (cdr mode-elem)))
+ (mc--run-hooks 'mode-compile-after-compile-hook))
+ ;; unknown mode: try to guess
+ (mc--msg (substitute-command-keys
+ "Don't know how to compile in %s mode, guessing... \\[mode-compile-kill] to kill.")
+ mode-name)
+ (mc--run-hooks 'mode-compile-before-compile-hook)
+ ;; mc--funcall can launch the compilation
+ ;; in another frame.
+ (mc--funcall 'guess-compile)
+ (mc--run-hooks 'mode-compile-after-compile-hook)))))
+
+(provide 'mode-compile)
+\f
+
+;;;###autoload
+(defun mode-compile-kill()
+ "*Kill the running compilation launched by `mode-compile' (\\[mode-compile]) \
+command.
+
+The compilation command is killed according to the current major mode
+the function was invoked from.
+
+Currently know how to kill compilations from:
+ `c-mode' , -- function kill-compilation.
+ `java-mode' , -- function kill-compilation.
+ `c++-mode' , -- function kill-compilation.
+ `ada-mode' , -- function kill-compilation.
+ `fortran-mode' , -- function kill-compilation.
+ `emacs-lisp-mode' -- function keyboard-quit.
+ `lisp-interaction-mode' -- function keyboard-quit.
+ `makefile-mode' -- function kill-compilation.
+ `dired-mode' -- function kill-compilation.
+ `sh-mode' -- function kill-compilation.
+ `csh-mode' -- function kill-compilation.
+ `zsh-mode' -- function kill-compilation.
+ `perl-mode' -- function kill-compilation.
+ `cperl-mode' -- function kill-compilation.
+ `tcl-mode' -- function kill-compilation.
+ `python-mode' -- function kill-compilation.
+ `fundamental-mode' -- Bound dynamically.
+ `text-mode' -- Bound dynamically.
+ `indented-text-mode' -- Bound dynamically.
+ `compilation-mode' -- function kill-compilation.
+
+The variable `mode-compile-modes-alist' contain description of ALL
+known modes. The hooks variables `mode-compile-before-kill-hook' and
+`mode-compile-after-kill-hook' are run just before and after invoking
+the kill compile command of the mode.
+
+Bound on \\[mode-compile-kill]."
+ (interactive)
+ (let ((mode-elem (assq major-mode mode-compile-modes-alist)))
+ (if mode-elem
+ ;; known mode
+ (progn
+ (mc--run-hooks 'mode-compile-before-kill-hook)
+ (mc--msg "Killing compilation in %s mode..." mode-name)
+ (let ((killfun (or (car-safe (cdr (cdr mode-elem)))
+ mc--kill-compile
+ nil)))
+ (if killfun
+ ;; I don't call mc--funcall here caus' we don't need
+ ;; to switch to another frame to kill a compilation.
+ (funcall killfun)
+ (mc--msg "Unable to kill compilation in %s mode..." mode-name))
+ (mc--run-hooks 'mode-compile-after-kill-hook)))
+ ;; unknown mode
+ (mc--msg "Don't know how to kill compilation in %s mode"
+ mode-name))))
+
+(provide 'mode-compile-kill)
+
+\f
+
+;;; Local variables:
+;;; outline-regexp: ";; @+"
+;;; eval: (outline-minor-mode 1)
+;;; End:
+
+;;; mode-compile.el ends here
--- /dev/null
+;; mutt.el --- Use Emacs 20 as an external editor for the Mutt mailer
+;; Copyright 1998 Eric Kidd
+
+;; Author: Eric Kidd <eric.kidd@pobox.com>
+;; Version: $Revision: 1.4 $
+
+;; This is free software distributed under the GPL, yadda, yadda, yadda.
+;; It has no warranty. See the GNU General Public License for more
+;; information. Send me your feature requests and patches, and I'll try
+;; to integrate everything.
+
+;;; Commentary:
+
+;; This is a major mode for use with Mutt, the spiffy *nix mailreader
+;; du jour. See <http://www.cs.hmc.edu/~me/mutt/index.html>. To use this
+;; mode, add the following line to the .emacs file in your home directory:
+;;
+;; (load "/your/local/path/to/this/file/mutt")
+;;
+;; Note that you can omit to ".el" from the file name when calling load.
+;;
+;; If you want to make it available to all your users, type \C-h v
+;; load-path RET, pick an appropriate directory for mutt.el, and modify
+;; your sitewide default.el to (require 'mutt).
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Thanks
+;;;
+;;; Dave Pearson: Code, feature ideas, Mutt experience. Many thanks!
+;;; Louis Theran: Encouragement to make Mutt mode work like Emacs MUAs.
+;;; Ronald: Enlightening gripes about what Emacs should do, but doesn't.
+;;; Robert Napier: Bug reports about font-lock mode, fancy wrapping.
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Revision History
+;;;
+;;; $Log: mutt.el,v $
+;;; Revision 1.4 1998/04/11 00:05:46 emk
+;;; Fixed font-lock bug. Also made mutt-mode a little more careful about
+;;; saving various bits of Emacs state when moving around the buffer.
+;;;
+;;; Revision 1.3 1998/03/25 00:37:36 emk
+;;; Added support for menus and font-lock mode, plus a few bug fixes.
+;;;
+;;; Revision 1.2 1998/03/24 13:19:46 emk
+;;; Major overhaul--more commands, a minor mode for header editing, and other
+;;; desirable features. Attaching files seems to be broken, though.
+;;;
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Required Packages
+
+(require 'derived)
+(require 'cl) ; Big but featureful. Do we need this?
+(require 'easymenu)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Customization Support
+;;;
+;;; Set up our customizable features. You can edit these (and lots of other
+;;; fun stuff) by typing M-x customize RET. The Mutt preferences can be
+;;; found under the [Applications] [Mail] category.
+
+(defgroup mutt nil
+ "Composing e-mail messages with Mutt.
+Emacs can run as an external editor for Mutt, the spiffy Unix mail reader
+du jour. You can get Mutt from <http://www.cs.hmc.edu/~me/mutt/index.html>."
+ :group 'mail)
+
+(defcustom mutt-uses-fill-mode t
+ "*Specifies whether Mutt should automatically wrap lines.
+Set this to t to enable line wrapping, and nil to disable line
+wrapping. Note that if a paragraph gets messed up (the line wrapper
+is very primitive), you can type \\[fill-paragraph] to rewrap the paragraph."
+ :type 'boolean
+ :group 'mutt)
+
+(defcustom mutt-signature-pattern "\\(--\\|Cheers,\\|\f\\)"
+ "*Pattern for identifying signatures.
+Mutt uses this to locate signatures. It should contain no leaading or
+trailing whitespace."
+ :type 'string
+ :group 'mutt)
+
+(defcustom mutt-file-pattern "mutt-[a-z]+-[0-9]+-[0-9]+\\'"
+ "*Regular expression which matches Mutt's temporary files."
+ :type 'string
+ :group 'mutt)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Customizable Faces
+;;; The dark background versions are probably uglier than the light
+;;; (which I use). If you find a more attractive, subdued color scheme,
+;;; please mail it to me.
+
+(defgroup mutt-faces nil
+ "Typefaces used for composing messages with Mutt."
+ :group 'mutt
+ :group 'faces)
+
+(defface mutt-header-keyword-face
+ '((((class color)
+ (background light))
+ (:foreground "Navy" :bold t))
+ (((class color)
+ (background dark))
+ (:foreground "LightBlue" :bold t))
+ (t
+ (:bold t)))
+ "Face used for displaying keywords (e.g. \"From:\") in headers."
+ :group 'mutt-faces)
+
+(defface mutt-header-value-face
+ '((((class color)
+ (background light))
+ (:foreground "MidnightBlue"))
+ (((class color)
+ (background dark))
+ (:foreground "LightSteelBlue")))
+ "Face used for displaying the values of headers."
+ :group 'mutt-faces)
+
+(defface mutt-quoted-text-face
+ '((((class color)
+ (background light))
+ (:foreground "Sienna" :italic t))
+ (((class color)
+ (background dark))
+ (:foreground "Wheat" :italic t))
+ (t
+ (:bold t :italic t)))
+ "Face used for displaying text which has been quoted (e.g. \">foo\")."
+ :group 'mutt-faces)
+
+(defface mutt-multiply-quoted-text-face
+ '((((class color)
+ (background light))
+ (:foreground "Firebrick" :italic t))
+ (((class color)
+ (background dark))
+ (:foreground "Tan" :italic t))
+ (t
+ (:italic t)))
+ "Face used for text which has been quoted more than once (e.g. \">>foo\")."
+ :group 'mutt-faces)
+
+(defvar mutt-font-lock-keywords
+ '(("^\\([A-Z][-A-Za-z0-9.]+:\\)\\(.*\\)$"
+ (1 'mutt-header-keyword-face)
+ (2 'mutt-header-value-face))
+ ("^[ \t\f]*\\(>[ \t\f]*[^ \t\f>].*\\)$"
+ (1 'mutt-quoted-text-face))
+ ("^[ \t\f]*\\(>[ \t\f]*\\)\\(>.*\\)$"
+ (1 'mutt-quoted-text-face)
+ (2 'mutt-multiply-quoted-text-face)))
+ "Highlighting rules for message mode.")
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Interactive Commands
+
+(defun mutt-save-current-buffer-and-exit ()
+ "Save the current buffer and exit Emacs."
+ (interactive)
+ (basic-save-buffer)
+ (save-buffers-kill-emacs))
+
+(defun mutt-delete-quoted-signatures ()
+ "Delete quoted signatures from buffer."
+ (interactive)
+ (goto-char (point-min))
+ (flush-lines (concat "^\\([ \t\f]*>[ \t\f>]*\\)"
+ mutt-signature-pattern
+ "[ \t\f]*\\(\n\\1.*\\)*")))
+
+(defun mutt-delete-old-citations ()
+ "Delete citations more than one level deep from buffer."
+ (interactive)
+ (goto-char (point-min))
+ (flush-lines "^[ \t\f]*>[ \t\f]*>[ \t\f>]*"))
+
+(defun mutt-goto-body ()
+ "Go to the beginning of the message body."
+ (interactive)
+ (goto-char (point-min))
+ ;; If the message has headers, slide downward.
+ (and headers-mode
+ (save-match-data (re-search-forward "^$" nil t))
+ (next-line 1)))
+
+(defun mutt-goto-signature ()
+ "Go to the beginning of the message signature."
+ (interactive)
+ (goto-char (point-max))
+ (and (save-match-data
+ (re-search-backward (concat "^" mutt-signature-pattern
+ "[ \t\f]*$")
+ nil t))
+ (previous-line 1)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Mutt Mode Meat
+
+(define-derived-mode mutt-mode text-mode "Mutt"
+ "Major mode for composing E-mail with the Mutt mailer.
+To customize it, type \\[customize] and select [Applications] [Mail] [Mutt].
+When you finish editing this message, type \\[mutt-save-current-buffer-and-exit] to save and exit Emacs.
+
+\\{mutt-mode-map}"
+
+ (rename-buffer "*Composing*" t)
+ (auto-fill-mode (if mutt-uses-fill-mode 1 0))
+
+ ;; Make Emacs smarter about wrapping citations and paragraphs.
+ ;; We probably can't handle Supercited messages, though.
+ (make-local-variable 'paragraph-start)
+ (make-local-variable 'paragraph-separate)
+ (setq paragraph-start
+ "\\([ \t\n\f]+[^ \t\n\f>]\\|[ \t\f>]*$\\)"
+ paragraph-separate
+ "[ \t\f>]*$")
+
+ ;; If Mutt passed us headers, activate the necessary commands.
+ (when (looking-at "^[-A-Za-z0-9]+:")
+ (headers-mode 1))
+
+ ;; Our temporary file lives in /tmp. Yuck! Compensate appropriately.
+ (make-local-variable 'backup-inhibited)
+ (setq backup-inhibited t)
+ (cd "~")
+
+ (make-local-variable 'font-lock-defaults)
+ (setq font-lock-defaults '(mutt-font-lock-keywords t))
+
+ (mutt-goto-body)
+ (message (substitute-command-keys "Type \\[describe-mode] for help composing; \\[mutt-save-current-buffer-and-exit] when done.")))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Mutt Headers Mode
+
+(defvar headers-mode nil)
+
+(defun headers-mode (&optional arg)
+ "Commands for editing the headers of an e-mail or news message.
+
+\\{headers-mode-map}"
+
+ (interactive "P")
+ (make-local-variable 'headers-mode)
+ (setq headers-mode
+ (if (null arg)
+ (not headers-mode)
+ (> (prefix-numeric-value arg) 0)))
+ (force-mode-line-update))
+
+(defvar headers-mode-map (make-sparse-keymap)
+ "Keymap used for editing RFC822 headers.")
+
+(defun headers-position-on-value ()
+ (beginning-of-line)
+ (skip-chars-forward "-A-Za-z0-9:")
+ ;; XXX - Should make sure we stay on line.
+ (forward-char))
+
+(defun headers-goto-field (field)
+ (let ((case-fold-search t))
+ (goto-char (point-min))
+ (save-match-data
+ (when (re-search-forward (concat "^\\($\\|" field ": \\)"))
+ (if (looking-at "^$")
+ (progn
+ (insert-string field ": \n")
+ (forward-char -1))
+ (headers-position-on-value))))))
+
+(defmacro define-header-goto (name header)
+ `(defun ,name ()
+ ,(concat "Position the cursor on the " header ": header.")
+ (interactive)
+ (headers-goto-field ,header)))
+
+(define-header-goto headers-goto-to "To")
+(define-header-goto headers-goto-cc "Cc")
+(define-header-goto headers-goto-fcc "Fcc")
+(define-header-goto headers-goto-summary "Summary")
+(define-header-goto headers-goto-keywords "Keywords")
+(define-header-goto headers-goto-subject "Subject")
+(define-header-goto headers-goto-bcc "Bcc")
+(define-header-goto headers-goto-reply-to "Reply-To")
+(define-header-goto headers-goto-from "From")
+(define-header-goto headers-goto-organization "Organization")
+
+(defun headers-attach-file (file description)
+ "Attach a file to the current message (works with Mutt)."
+ (interactive "fAttach file: \nsDescription: ")
+ (when (> (length file) 0)
+ (save-excursion
+ (save-match-data
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (search-forward-regexp "^$")
+ (insert-string (concat "Attach: " (file-truename file) " "
+ description "\n"))
+ (message (concat "Attached '" file "'.")))))))
+
+(or (assq 'headers-mode minor-mode-alist)
+ (setq minor-mode-alist
+ (cons '(headers-mode " Headers") minor-mode-alist)))
+
+(or (assq 'headers-mode minor-mode-map-alist)
+ (setq minor-mode-map-alist
+ (cons (cons 'headers-mode headers-mode-map)
+ minor-mode-map-alist)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Key Bindings
+
+(define-key mutt-mode-map "\C-c\C-c" 'mutt-save-current-buffer-and-exit)
+(define-key mutt-mode-map "\C-c\C-d\C-s" 'mutt-delete-quoted-signatures)
+(define-key mutt-mode-map "\C-c\C-d\C-c" 'mutt-delete-old-citations)
+(define-key mutt-mode-map "\C-c\C-b" 'mutt-goto-body)
+(define-key mutt-mode-map "\C-c\C-i" 'mutt-goto-signature)
+
+(define-key headers-mode-map "\C-c\C-f\C-t" 'headers-goto-to)
+(define-key headers-mode-map "\C-c\C-f\C-c" 'headers-goto-cc)
+(define-key headers-mode-map "\C-c\C-f\C-w" 'headers-goto-fcc)
+(define-key headers-mode-map "\C-c\C-f\C-u" 'headers-goto-summary)
+(define-key headers-mode-map "\C-c\C-f\C-k" 'headers-goto-keywords)
+(define-key headers-mode-map "\C-c\C-f\C-s" 'headers-goto-subject)
+(define-key headers-mode-map "\C-c\C-f\C-b" 'headers-goto-bcc)
+(define-key headers-mode-map "\C-c\C-f\C-r" 'headers-goto-reply-to)
+(define-key headers-mode-map "\C-c\C-f\C-f" 'headers-goto-from)
+(define-key headers-mode-map "\C-c\C-f\C-o" 'headers-goto-organization)
+(define-key headers-mode-map "\C-c\C-a" 'headers-attach-file)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Menus
+
+(easy-menu-define
+ mutt-mode-menu mutt-mode-map "Mutt Message Composition Commands."
+ '("Mutt"
+ ["Delete Quoted Signatures" mutt-delete-quoted-signatures t]
+ ["Delete Doubly-Quoted Text" mutt-delete-old-citations t]
+ "----"
+ ["Go To Body of Message" mutt-goto-body t]
+ ["Go To Signature of Message" mutt-goto-signature t]
+ "----"
+ ["Save Message and Return to Mutt" mutt-save-current-buffer-and-exit t]))
+
+(easy-menu-define
+ headers-mode-menu headers-mode-map "Header Editing Commands."
+ '("Headers"
+ ["Attach File..." headers-attach-file t]
+ "----"
+ ["Edit From Header" headers-goto-from t]
+ ["Edit Subject Header" headers-goto-subject t]
+ ["Edit To Header" headers-goto-to t]
+ ["Edit Cc Header" headers-goto-cc t]
+ ["Edit Bcc Header" headers-goto-bcc t]
+ ["Edit Fcc Header" headers-goto-fcc t]
+ ["Edit Reply-To Header" headers-goto-reply-to t]
+ ["Edit Summary Header" headers-goto-summary t]
+ ["Edit Keywords Header" headers-goto-keywords t]
+ ["Edit Organization Header" headers-goto-organization t]))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Finish Installing Mutt Mode
+
+(unless (assq mutt-file-pattern auto-mode-alist)
+ (setq auto-mode-alist
+ (cons (cons mutt-file-pattern 'mutt-mode)
+ auto-mode-alist)))
+
+(provide 'mutt)
--- /dev/null
+; $Id: post.el,v 2.4 2004/07/23 23:13:17 rreid Exp rreid $
+;; post.el --- Use (X?)Emacs(client) as an external editor for mail and news.
+
+;;; Authors: Eric Kidd <eric.kidd@pobox.com>,
+;;; Dave Pearson <davep@davep.org>,
+;;; Rob Reid <reid@astro.utoronto.ca>,
+;;; Roland Rosenfeld <roland@spinnaker.de>
+
+;; This is free software distributed under the GPL, yadda, yadda, yadda.
+;; It has no warranty. See the GNU General Public License for more
+;; information. Send us your feature requests and patches, and we'll try
+;; to integrate everything.
+
+;;; Maintainer: Rob Reid <reid@astro.utoronto.ca>
+
+;;; Keywords: mail
+
+;;; Commentary:
+;; This is a major mode for use with Mutt, the spiffy *nix mailreader du jour
+;; (See http://www.mutt.org/), slrn, the spiffy *nix newsreader du jour, or
+;; whatever you can get it to work with. To use this mode, add the following
+;; line to the .emacs file in your home directory:
+;;
+;; (load "/your/local/path/to/this/file/post")
+;;
+;; Note that you can omit the ".el" from the file name when calling load.
+;;
+;; If you want to make it available to all your users, type \C-h v
+;; load-path RET, pick an appropriate directory for post.el, and modify
+;; your sitewide default.el to (require 'post).
+;;
+;; You may find the latest version of this mode at
+;; http://astro.utoronto.ca/~reid/mutt/
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; BUGS:
+;;
+;; Rob: I predict that some buffers (*Original*<2>, *Composing*<2>?)
+;; will be left behind if you edit more than one message at a time.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Thanks
+;;;
+;;; Dave Pearson: Code, feature ideas, Mutt experience. Many thanks!
+;;; Louis Theran: Encouragement to make Mutt mode work like Emacs MUAs.
+;;; Ronald: Enlightening gripes about what Emacs should do, but doesn't.
+;;; Robert Napier: Bug reports about font-lock mode, fancy wrapping.
+;;; Kevin Rodgers: Answered RR's question on gnu.emacs.help on
+;;; overwriting server-process-filter's annoying message at startup.
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Revision History
+;;;
+;;; $Log: post.el,v $
+;;; Revision 2.401 2004/07/23 16:27:29 rreid
+;;; Fixed post-delete-quoted-signatures to not remove sneaky things like quoted
+;;; double dash arrows. Thanks go to Felix Klee for a clear bug report.
+;;;
+;;; Revision 2.4 2002/04/22 22:04:29 reid
+;;; Tweaked post-emoticon-pattern yet again. Made cl mandatory for all
+;;; versions of emacs. (Thanks to Eric Dorland and Mike Schiraldi for bug
+;;; reports.) Fixed post-unquote-region. (Thanks to Mike Schiraldi for the
+;;; bug report.)
+;;;
+;;; Revision 2.3 2002/04/21 20:13:55 reid
+;;; Improved post-emoticon-pattern.
+;;;
+;;; Revision 2.2 2002/04/20 04:12:54 reid
+;;; Improved post-emoticon-pattern.
+;;;
+;;; Revision 2.1 2002/04/20 03:17:48 reid
+;;; - A major (but not total) synchronization with Dave Pearson's post-mode.
+;;; header-set-followup-to and header-set-organization should work now.
+;;; - Syntax highlighting now works for quoted email addresses and URLs.
+;;; - *bold* words are now highlighted.
+;;; - Emoticons can now be highlighted, and the default regexp,
+;;; post-emoticon-pattern, might be too enthusiastic for your taste. In case
+;;; you're curious, I verified that gnus' smiley-ems.el works with post, but I
+;;; decided that it wasn't ideal.
+;;; - post-url-text-pattern changed to post-url-pattern and made more enthusiastic.
+;;;
+;;; revision 1.95 2002/04/10 00:06:26 reid
+;;; Fixed the regexp in post-kill-signature to not delete everything between
+;;; mutt's standard forwarding lines. post-kill-signature is called indirectly
+;;; by many functions.
+;;;
+;;; Revision 1.9 2002/04/04 22:24:31 reid
+;;; Applied a patch (not quite verbatim) from The Anarcat
+;;; <anarcat@anarcat.dyndns.org> to make the entity separating siglets in
+;;; `post-variable-signature-source' a regexp, `post-signature-sep-regexp'. The
+;;; default works either either the old post file format or strfiled (fortune)
+;;; files.
+;;;;
+;;; Changed default `post-random-signature-command' to `fortune
+;;; ~/.mutt/sigs.fortune'.
+;;;
+;;; `post-random-signature-command' should now NOT supply a fixed sig portion!
+;;;
+;;; (post-el-random-signature) supplied by The Anarcat to do random sig
+;;; selection purely within Emacs Lisp.
+;;;
+;;; Revision 1.8 2002/02/06 22:24:31 eric
+;;; clean up
+;;;
+;;; Revision 1.7.2 2002/02/06 22:17:01 eric
+;;; tweak regexps, make font-lock-comment-face be post-signature-text-face
+;;;
+;;; Revision 1.7.1 2002/02/06 21:58:58 eric
+;;; tweak regexp, change some types to regexp
+;;;
+;;; Revision 1.7.0 2002/02/06 21:36:56 eric
+;;; hilight signatures, urls and emails
+;;;
+;;; Revision 1.6.3.10 1999/10/11 00:29:41 roland
+;;; Corrected color quoting again: Now allows ">" in the middle of
+;;; a line which is quoted twice.
+;;;
+;;; Revision 1.6.3.9 1999/10/08 10:43:18 roland
+;;; Add third level of quoting faces.
+;;; Allow super-cite name prefixes before quote signs.
+;;;
+;;; Revision 1.6.3.8 1999/10/08 08:39:00 roland
+;;; post-font-lock-keywords now detects lines with only "> "in it
+;;; correctly (merged following line into it before).
+;;;
+;;; Revision 1.6.3.7 1999/10/04 10:07:48 roland
+;;; Add post-quote-region and post-unquote-region commands to quote and
+;;; unquote a region (one level).
+;;;
+;;; Revision 1.6.3.6 1999/09/03 23:13:55 reid
+;;; Valeriy E. Ushakov <uwe@ptc.spbu.ru> pointed out that (GNU) Emacs <20 has
+;;; fewer (optional) arguments to (read-string) than what I was using to
+;;; inherit the input method. I didn't find a way off the top of my head
+;;; to redefine (read-string) without causing an infinite loop, so I have
+;;; substituted a macro (string-read prompt) which does the right thing,
+;;; so please use it instead of read-string.
+;;;
+;;; Revision 1.6.3.5 1999/08/29 19:58:49 reid
+;;; Changed default post-mail-message to handle hostnames with digits.
+;;; Thanks to Brian D. Winters <brianw@alumni.caltech.edu>.
+;;;
+;;; Revision 1.6.3.4 1999/03/20 03:02:05 reid
+;;; Made post compatible with emacs as far back as 19.28.1, probably
+;;; farther.
+;;;
+;;; Revision 1.6.3.3 1999/03/16 03:14:07 reid
+;;; Cleaned up post-select-signature-select-sig-from-file code.
+;;;
+;;; Revision 1.6.3.2 1999/03/16 03:05:12 reid
+;;; Fixed alist updating.
+;;;
+;;; Revision 1.6.3.1 1999/03/13 02:23:48 reid
+;;; Added defface to the list of things that get defined if customize
+;;; hasn't already done it. Thanks to Melissa Binde for the bug report.
+;;;
+;;; Modified post-body-says-attach to use a regexp,
+;;; post-attachment-regexp, so that something like "\(attach\|anbringen\)"
+;;; can be used by bilingual people like Roland.
+;;;
+;;; Revision 1.6.2.1 1999/03/12 10:16:11 roland
+;;; Added missing () to post-insert-to-auto-mode-alist-on-load.
+;;;
+;;; Revision 1.6.2 1999/03/11 15:51 Dave Pearson
+;;; header-position-on-value fixed to return (point), and
+;;; defcustom macro provided for Emacs 19 users.
+;;;
+;;; Revision 1.6.1.2 1999/03/06 11:24:43 roland
+;;; Added post-insert-to-auto-mode-alist-on-load.
+;;;
+;;; Revision 1.6.1.1 1999/03/06 11:02:27 roland
+;;; Customized renaming of buffer.
+;;; Removed different handling for mail, news, news-reply.
+;;; Fixed problems with easy-menu under XEmacs.
+;;;
+;;; Revision 1.6.0 1999/03/04 18:04 Rob Reid
+;;; Returned post-signature-pattern to using "--" instead of "-- "
+;;; because some senders have broken MTAs (as Eric reminded me) and
+;;; some users don't use procmail to compensate. This time all of the
+;;; functions dealing with signatures have been smartened up to avoid
+;;; false matches. Unfortunately that means they don't use
+;;; post-signature-pattern in its raw form.
+;;;
+;;; Added post-backup-original so that Dave's post-copy-original can
+;;; be used.
+;;;
+;;; Kevin Rodgers explained how to put this in .emacs to fix the
+;;; server-process-filter's annoying message problem:
+;;;
+;;; Revision 1.1 1999/03/04 18:02:30 reid
+;;; Initial revision
+;;;
+;;; %%%%%%%%%%%% Put in .emacs %%%%%%%%%%%
+;;;
+;;; ;;; Email
+;;; (server-start)
+;;; (load "/home/reid/.mutt/post")
+;;; (defadvice server-process-filter (after post-mode-message first activate)
+;;; "If the buffer is in post mode, overwrite the server-edit
+;;; message with a post-save-current-buffer-and-exit message."
+;;; (if (eq major-mode 'post-mode)
+;;; (message
+;;; (substitute-command-keys "Type \\[describe-mode] for help composing; \\[post-save-current-buffer-and-exit] when done."))))
+;;; ; This is also needed to see the magic message. Set to a higher
+;;; ; number if you have a faster computer or read slower than me.
+;;; '(font-lock-verbose 1000)
+;;; ; (setq server-temp-file-regexp "mutt-")
+;;; (add-hook 'server-switch-hook
+;;; (function (lambda()
+;;; (cond ((string-match "Post" mode-name)
+;;; (post-goto-body))))))
+;;;
+;;; %%%%%%%%% We now return to our regular commentary %%%%%%%%%
+;;;
+;;; Eric Kidd asked that the name of Headers mode be changed so that
+;;; it doesn't conflict with mutt-mode's Headers, so I changed it to
+;;; just Header (no s).
+;;;
+;;; Revision 1.5? 1999/02/27 17:30 Rob Reid
+;;; I had a go at combining Dave Pearson's post mode with Eric Kidd's
+;;; Mutt mode. Since Dave Pearson's post mode explicitly handles news as
+;;; well as email, and this should be useful for more than just mutt,
+;;; I'm calling it post mode. I also added functions for picking
+;;; random signatures, selecting a signature from a file, and
+;;; intelligently (IMHO) prompting the user for an attachment when
+;;; necessary. Changed mutt-save-buffer-and-exit to work better with
+;;; emacsclient, and some of the key bindings. post-signature-pattern
+;;; now defaults to use "-- " instead of "--", and I have far less
+;;; trouble this way (I use procmail to clean up braindead "--"s.). I
+;;; don't know why Eric warned against trailing whitespace.
+;;;
+;;; Revision 1.4 1998/04/11 00:05:46 emk
+;;; Fixed font-lock bug. Also made mutt-mode a little more careful about
+;;; saving various bits of Emacs state when moving around the buffer.
+;;;
+;;; Revision 1.3 1998/03/25 00:37:36 emk
+;;; Added support for menus and font-lock mode, plus a few bug fixes.
+;;;
+;;; Revision 1.2 1998/03/24 13:19:46 emk
+;;; Major overhaul--more commands, a minor mode for header editing, and other
+;;; desirable features. Attaching files seems to be broken, though.
+;;;
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Required Packages
+
+(require 'cl)
+(require 'derived)
+(require 'easymenu)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Customization Support
+;;;
+;;; Set up our customizable features. You can edit these (and lots of other
+;;; fun stuff) by typing M-x customize RET. The Post preferences can be
+;;; found under the [Applications] [Mail] category.
+
+;; Make post mode a bit more compatible with older (i.e. <20) versions of emacs.
+;;; Code:
+(eval-and-compile
+ ;; Dumb down read-string if necessary.
+ ;; The number of optional arguments for read-string seems to increase
+ ;; sharply with (emacs-version). Since old versions of emacs are a large
+ ;; source of bug reports it might be worth writing (or looking for)
+ ;; (bug-report reid@astro.utoronto.ca) which emails me the result of
+ ;; (emacs-version) along with a user supplied description of the problem.
+ ;; GNU Emacs 19.28.1 only has INITIAL-STRING as an optional argument.
+ ;; 19.34.1 has (read-string PROMPT &optional INITIAL-INPUT HISTORY). 20.2.1
+ ;; has (read-string PROMPT &optional INITIAL-INPUT HISTORY DEFAULT-VALUE
+ ;; INHERIT-INPUT-METHOD).
+ ;; Since I haven't found a way of redefining read-string without causing an
+ ;; infinite loop, please use (string-read prompt).
+ (if (< (string-to-number (substring (emacs-version)
+ (string-match "[0-9]+\.[0-9]"
+ (emacs-version) 5))) 20)
+ (defmacro string-read (prompt) (` (read-string (, prompt))))
+ (defmacro string-read (prompt)
+ (` (read-string (, prompt) nil nil nil t))))
+
+ ;; XEmacs gnuserv uses slightly different functions than the GNU Emacs
+ ;; server, and some people are still wasting time and CPU cycles by starting
+ ;; up a new emacs each time.
+ (cond ((fboundp 'server-edit)
+ (fset 'post-finish 'server-edit))
+ ((fboundp 'gnuserv-kill-buffer-function)
+ (fset 'post-finish 'gnuserv-kill-buffer-function))
+ (t
+ (fset 'post-finish 'save-buffers-kill-emacs)))
+
+ ;; If customize isn't available just use defvar instead.
+ (unless (fboundp 'defgroup)
+ (defmacro defgroup (&rest rest) nil)
+ (defmacro defcustom (symbol init docstring &rest rest)
+ ; The "extra" braces and whitespace are for emacs < 19.29.
+ (` (defvar (, symbol) (, init) (, docstring))))
+ (defmacro defface (&rest args) nil))
+ (unless (fboundp 'buffer-substring-no-properties)
+ (fset 'buffer-substring-no-properties 'buffer-substring)))
+
+(defgroup post nil
+ "Composing e-mail messages with Post.
+Emacs can run as an external editor for Mutt, the spiffy Unix mail reader
+du jour, or slrn, the spiffy Unix news reader du jour. You can get
+Mutt from http://www.mutt.org/."
+ :group 'mail)
+
+(defcustom post-uses-fill-mode t
+ "*Specifies whether Post should automatically wrap lines.
+Set this to t to enable line wrapping, and nil to disable line
+wrapping. Note that if a paragraph gets messed up (the line wrapper
+is very primitive), you can type \\[fill-paragraph] to rewrap the paragraph."
+ :type 'boolean
+ :group 'post)
+
+(defcustom post-mail-message "mutt-[a-z0-9]+-[0-9]+-[0-9]+\\'"
+ "*Regular expression which matches your mailer's temporary files."
+ :type 'string
+ :group 'post)
+
+(defcustom post-news-posting "\\.\\(followup\\|letter\\|article\\)$"
+ "*Regular expression which matches your news reader's composition files."
+ :type 'string
+ :group 'post)
+
+(defcustom post-backup-original nil
+ "*Controls whether a pristine backup of the original is kept for reference."
+ :type 'boolean
+ :group 'post)
+
+(defcustom post-signature-pattern "\\(--\\|Cheers,\\|\f\\)"
+ "*Pattern signifying the beginning of signatures.
+It should not contain trailing whitespace unless you know what you're doing."
+ :type 'regexp
+ :group 'post)
+
+(defcustom post-signature-sep-regexp "^\\(%\\|^L\\|--\\)?\n"
+ "*Regular expression delimiting signatures in the signature file.
+This allows the use of classic fortune files as signature files.
+This should normally contain a newline."
+ :type 'regexp
+ :group 'post)
+
+(defcustom post-signature-source-is-file t
+ "*Toggles the signature source type between file and directory."
+ :type 'boolean
+ :group 'post)
+
+(defcustom post-variable-signature-source "~/.mutt/sigs.fortune"
+ "*Location of the variable part of your signature.
+Post uses this to locate signatures. It can be either a directory
+with one item per file or a file with items separated by blank lines."
+ :type 'string
+ :group 'post)
+
+(defcustom post-fixed-signature-source "~/.fixedsig"
+ "*File with the fixed part of your signature."
+ :type 'string
+ :group 'post)
+
+(defcustom post-signature-directory "~/.sigs/"
+ "*The directory that contains your collection of signature files."
+ :type 'string
+ :group 'post)
+
+(defcustom post-signature-wildcard "sig*"
+ "*Wildcard for finding signature files in your signature directory."
+ :type 'string
+ :group 'post)
+
+(defcustom post-random-signature-command "fortune ~/.mutt/sigs.fortune"
+ "*Command to run to get a random signature.
+Examples are available at http://astro.utoronto.ca/~reid/mutt/"
+ :type 'string
+ :group 'post)
+
+(defcustom post-kill-quoted-sig t
+ "Specifies whether `post-mode' should automatically kill quoted signatures."
+ :type 'boolean
+ :group 'post)
+
+(defcustom post-jump-header t
+ "Specifies wheather `post-mode' should jump to the body."
+ :type 'boolean
+ :group 'post)
+
+(defcustom post-force-pwd-to-home t
+ "Specifies whether `post-mode' should cd to your home directory."
+ :type 'boolean
+ :group 'post)
+
+(defcustom post-email-address (concat (user-login-name) "@" mail-host-address)
+ "*Your email address."
+ :type 'string
+ :group 'post)
+
+(defcustom post-should-prompt-for-attachment 'Smart
+ "*Controls whether an attachment will be prompted for before saving
+the message and exiting. 'Smart' will prompt only if the body
+contains post-attachment-regexp."
+ :type '(choice (const Never)
+ (const Smart)
+ (const Always))
+ :group 'post)
+
+(defcustom post-attachment-regexp "attach"
+ "*This is what post looks for in the body if
+post-should-prompt-for-attachment is 'Smart'."
+ :type 'regexp
+ :group 'post)
+
+(defcustom post-news-poster-regexp "^On .*<.*>.*wrote:$"
+ "Regular expression used to locate the attribution line of a news posting."
+ :type 'regexp
+ :group 'post)
+
+(defcustom post-rename-buffer t
+ "Specify whether `post-mode' should rename the buffer to *Composing*."
+ :type 'boolean
+ :group 'post)
+
+(defcustom post-insert-to-auto-mode-alist-on-load t
+ "Automatically insert `post-mode' with `post-mail-message' to `auto-mode-alist'."
+ :type 'boolean
+ :group 'post)
+
+(defcustom post-mode-hook nil
+ "List of hooks to be executed on entry to `post-mode'."
+ :group 'post)
+
+(defcustom post-quote-start "> "
+ "Pattern which is added (or removed) at the beginning of the line by
+comment-region"
+ :group 'post)
+
+(defcustom post-email-address-pattern
+ "[A-Za-z0-9_][-A-Za-z0-9._]*@[-A-Za-z0-9._]*[A-Za-z0-9]"
+ "Pattern to detect email addresses."
+ :type 'regexp
+ :group 'post)
+
+(defcustom post-url-pattern
+ '("\\<\\(\\(https?\\|news\\|mailto\\|ftp\\|gopher\\):\\|\\(www\\|ftp\\)\\.\\)[-~A-Za-z0-9._/%$+?#]+[A-Za-z0-9/#]" "<URL:[^ ]+>")
+ "Pattern to detect URL addresses."
+ :type '(repeat regexp)
+ :group 'post)
+
+(defcustom post-bold-pattern '("\\*\\w+\\*")
+ "*List of regular expressions that define bold text."
+ :type '(repeat regexp)
+ :group 'post)
+
+(defcustom post-underline-pattern '("_\\w+_")
+ "*List of regular expressions that define underlined text."
+ :type '(repeat regexp)
+ :group 'post)
+
+(defcustom post-emoticon-pattern '("[0O(<{}]?[;:8B|][.,]?[-+^*o0O][{<>/\|]?[][)>(<|/\P][)>]?"
+ "\\s [(<]?[][)>(<|/\][}<>|]?[-+^*oO0][,.]?[:8][0O>]?"
+ "\\s [;:][][P)\/(]" "\\s [][)(P\/][:;]"
+ "<[Gg]>" "<[BbSs][Gg]>")
+ "*List of regular expressions that define a emoticon."
+ :type '(repeat regexp)
+ :group 'post)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Customizable Faces
+;;; If you find a more attractive color scheme for dark backgrounds, please
+;;; email it to reid@astro.utoronto.
+
+(defgroup post-faces nil
+ "Typefaces used for composing messages with Post."
+ :group 'post
+ :group 'faces)
+
+(defface post-header-keyword-face
+ '((((class color)
+ (background light))
+ (:foreground "Navy" :bold t))
+ (((class color)
+ (background dark))
+ (:foreground "LightBlue" :bold t))
+ (t
+ (:bold t)))
+ "Face used for displaying keywords (e.g. \"From:\") in header."
+ :group 'post-faces)
+
+(defface post-header-value-face
+ '((((class color)
+ (background light))
+ (:foreground "MidnightBlue"))
+ (((class color)
+ (background dark))
+ (:foreground "LightSteelBlue")))
+ "Face used for displaying the values of header."
+ :group 'post-faces)
+
+(defface post-quoted-text-face
+ '((((class color)
+ (background light))
+ (:foreground "Sienna" :italic t))
+ (((class color)
+ (background dark))
+ (:foreground "Wheat" :italic t))
+ (t
+ (:bold t :italic t)))
+ "Face used for displaying text which has been quoted (e.g. \">foo\")."
+ :group 'post-faces)
+
+(defface post-double-quoted-text-face
+ '((((class color)
+ (background light))
+ (:foreground "Firebrick" :italic t))
+ (((class color)
+ (background dark))
+ (:foreground "Tan" :italic t))
+ (t
+ (:italic t)))
+ "Face used for text which has been quoted twice (e.g. \">>foo\")."
+ :group 'post-faces)
+
+(defface post-multiply-quoted-text-face
+ '((((class color)
+ (background light))
+ (:foreground "goldenrod" :italic t))
+ (((class color)
+ (background dark))
+ (:foreground "tan3" :italic t))
+ (t
+ (:italic t)))
+ "Face used for text which has been quoted more than twice (e.g. \">>>foo\")."
+ :group 'post-faces)
+
+(defface post-signature-text-face
+ '((((class color)
+ (background light))
+ (:foreground "red3"))
+ (((class color)
+ (background dark))
+ (:foreground "red1"))
+ (t
+ (:bold t)))
+ "Face used for text that is part of a signature"
+ :group 'post-faces)
+
+(defface post-email-address-text-face
+ '((((class color)
+ (background light))
+ (:foreground "green3"))
+ (((class color)
+ (background dark))
+ (:foreground "green1"))
+ (t
+ (:italic t)))
+ "Face used for email addresses"
+ :group 'post-faces)
+
+(defface post-url-face
+ '((((class color)
+ (background light))
+ (:foreground "green3" :bold t))
+ (((class color)
+ (background dark))
+ (:foreground "green1" :bold t))
+ (t
+ (:italic t)))
+ "Face used for URL addresses"
+ :group 'post-faces)
+
+(defface post-emoticon-face
+ '((((class color)
+ (background light))
+ (:foreground "black" :background "yellow" :bold t))
+ (((class color)
+ (background dark))
+ (:foreground "black" :background "yellow" :bold t))
+ (t
+ (:bold t)))
+ "Face used for text matched by post-emoticon-pattern."
+ :group 'post-faces)
+
+(defface post-bold-face
+ '((((class color)
+ (background light))
+ (:bold t))
+ (((class color)
+ (background dark))
+ (:bold t))
+ (t
+ (:bold t)))
+ "Face used for text matching post-bold-pattern."
+ :group 'post-faces)
+
+(defface post-underline-face
+ '((((class color)
+ (background light))
+ (:underline t))
+ (((class color)
+ (background dark))
+ (:underline t))
+ (t
+ (:underline t)))
+ "Face used for text matching post-underline-pattern."
+ :group 'post-faces)
+
+; Note: some faces are added later!
+(defvar post-font-lock-keywords
+ `(("^\\([A-Z][-A-Za-z0-9.]+:\\)\\(.*\\)$"
+ (1 'post-header-keyword-face)
+ (2 'post-header-value-face))
+ ("^[ \t\f]*\\(>[ \t\f]*\\)\\([-a-zA-Z]*>[ \t\f]*\\)\\([-a-zA-Z]*>.*\\)$"
+ (1 'post-quoted-text-face)
+ (2 'post-double-quoted-text-face)
+ (3 'post-multiply-quoted-text-face))
+ ("^[ \t\f]*\\(>[ \t\f]*\\)\\([-a-zA-Z]*>.*\\)$"
+ (1 'post-quoted-text-face)
+ (2 'post-double-quoted-text-face))
+ ("^[ \t\f]*\\(>[ \t\f]*[^ \t\f\n>].*\\)$"
+ (1 'post-quoted-text-face))
+ ("^[ \t\f]*\\(>[ \t\f]*\\)$"
+ (1 'post-quoted-text-face))
+ (,post-email-address-pattern
+ (0 'post-email-address-text-face)))
+ "Highlighting rules for message mode.")
+
+;;; Declare global mode variables.
+
+(defconst post-font-lock-syntactic-keywords
+ `((,(concat "^" post-signature-pattern "[ \t\f]*$") 0 '(11))))
+
+(defun post-font-lock-syntactic-face-function (state)
+ "Function for font locking syntactic faces.
+Argument STATE ."
+post-signature-text-face)
+
+(defvar post-buf nil
+ "Name of the composing buffer.")
+
+(defvar post-select-signature-mode-map nil
+ "Local keymap for the select-signature buffer.")
+
+(defvar post-select-signature-last-buffer nil
+ "Pointer to the calling buffer.")
+
+(defvar post-select-signature-last-point nil
+ "Where we were in the calling buffer.")
+
+(defvar post-has-attachment nil
+ "Whether the message has an attachment.")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Interactive Commands
+
+(defun post-save-current-buffer-and-exit ()
+ "Save the current buffer and exit Emacs."
+ (interactive)
+
+ ;; Should the user be prompted for an attachment?
+ (cond (post-has-attachment)
+ ((equal post-should-prompt-for-attachment 'Never))
+ ((or (equal post-should-prompt-for-attachment 'Always)
+ (post-body-says-attach))
+ (post-prompt-for-attachment)))
+
+ (basic-save-buffer)
+
+ (if post-backup-original
+ (kill-buffer "*Original*"))
+
+ (post-finish)
+
+ ;; Added by Rob Reid 10/13/1998 to prevent accumulating *Composing* buffers
+ ;; when using (emacs|gnu)client. Helped by Eric Marsden's Eliza example in
+ ;; http://www.ssc.com/lg/issue29/marsden.html
+ (kill-buffer post-buf))
+
+(defun post-goto-body ()
+ "Go to the beginning of the message body."
+ (interactive)
+ (goto-char (point-min))
+ ;; If the message has header, slide downward.
+ (and header-mode (save-match-data (re-search-forward "^$" nil t))
+ (next-line 1)))
+
+(defun post-goto-signature ()
+ "Go to the beginning of the message signature."
+ (interactive)
+ (goto-char (point-max))
+ (and (save-match-data
+ (re-search-backward (concat "^" post-signature-pattern
+ "[ \t\f]*$")
+ nil t))))
+
+(defun post-delete-quoted-signatures ()
+ "Delete quoted signatures from buffer."
+ (interactive)
+ (goto-char (point-min))
+ (flush-lines (concat "^\\([ \t\f]*>[ \t\f>]*\\)"
+ post-signature-pattern
+ "[ \t\f]*\\(\n\\1.*\\)+")))
+
+(defun post-kill-signature ()
+ "Kill the signature from the buffer.
+Returns the point value for where the signature was or, if there isn't a
+signature, the point value of the end of the buffer"
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+; The .=*+|#@!~$%&()_- is to compensate for people who put ASCII art on the
+; same line as the sigdashes, and the $ at the end prevents this from deleting
+; everything between mutt's standard forwarding lines.
+ (cond ((search-forward-regexp (concat "^" post-signature-pattern
+ "[ \t\f.=*+|#@!~$%&()_-]*$") nil t)
+ (beginning-of-line)
+ (kill-region (point) (point-max)))
+ (t
+ (goto-char (point-max))))
+ (point)))
+
+(defun post-delete-old-citations ()
+ "Delete citations more than one level deep from buffer."
+ (interactive)
+ (goto-char (point-min))
+ (flush-lines "^[ \t\f]*>[ \t\f]*>[ \t\f>]*"))
+
+;;; Functions for messing with the body
+
+(defun post-make-region-bold (start end)
+ "Apply mutt's nroff style bold to a region of text.
+Argument START start of region.
+Argument END end of region."
+ (interactive "r")
+ (while (< start end)
+ (goto-char start)
+ (insert (buffer-substring-no-properties start (1+ start)))
+ (insert (char-to-string 8))
+ (setq start (+ start 3))
+ (setq end (+ end 2))))
+
+(defun post-make-region-underlined (start end)
+ "Apply mutt's nroff style underline to a region of text.
+Argument START start of region.
+Argument END end of region."
+ (interactive "r")
+ (while (< start end)
+ (goto-char start)
+ (insert "_")
+ (insert (char-to-string 8))
+ (setq start (+ start 3))
+ (setq end (+ end 2))))
+
+(defun post-quote-region (beg end)
+ "Quote a region using the `post-quote-start' variable.
+Argument BEG Beginning of region to be quoted.
+Argument END End of region to be quoted."
+ (interactive "r")
+ (comment-region beg end))
+
+(defun post-unquote-region (beg end)
+ "Un-quote a region one level using the `post-quote-start' variable.
+Argument BEG Beginning of region to be quoted.
+Argument END End of region to be quoted."
+ (interactive "r")
+ (uncomment-region beg end))
+
+; From Dave Pearson, July 15, 2000
+(defun* split-quoted-paragraph (&optional (quote-string "> "))
+ "Split a quoted paragraph at point, keeping the quote."
+ (interactive)
+ (if (save-excursion
+ (beginning-of-line)
+ (looking-at (regexp-quote quote-string)))
+ (progn
+ (let ((spaces (- (point)
+ (save-excursion
+ (beginning-of-line)
+ (point))
+ (length quote-string))))
+ (save-excursion
+ (insert (format "\n\n%s%s" quote-string (make-string spaces ? ))))))
+ (error "Can't see a quoted paragraph here")))
+
+(defun post-random-signature ()
+ "Randomize the signature.
+Set it to whatever `post-random-signature-command' spits out followed by the
+content of `post-fixed-signature-source', if available, or a nasty reminder if
+it is not."
+ (interactive)
+ (save-excursion
+ (goto-char (post-kill-signature))
+ (insert "-- \n")
+ (shell-command post-random-signature-command t)
+ (goto-char (point-max))
+ (if (file-readable-p post-fixed-signature-source)
+ (insert-file-contents post-fixed-signature-source)
+ (insert "I really need a `post-fixed-signature-source'!\n"))))
+
+(defun post-el-random-signature ()
+ "Choose a random signature from `post-variable-signature-source'.
+the signatures in `post-variable-signature-source' must be separated by
+`post-signature-sep-regexp'."
+ (interactive)
+ (let ((sig nil))
+ (save-excursion
+ (set-buffer (generate-new-buffer "*Post-Select-Signature*"))
+ (insert-file post-variable-signature-source)
+ (beginning-of-buffer)
+ ;; we have 2 lists of marks since seperators are of arbitrary lenght
+ (let ((marks-st (list (point-min)))
+ (marks-end (list))
+ (count 0)) ;nth counts from zero and random is [0,N)
+ (while (search-forward-regexp post-signature-sep-regexp nil "a")
+ (setq marks-st (cons (match-end 0) marks-st)
+ marks-end (cons (match-beginning 0) marks-end)
+ count (1+ count)))
+ (setq marks-end (cons (point-max) marks-end))
+ (let ((r (random (1+ count))))
+ (setq sig (buffer-substring-no-properties
+ (nth r marks-st) (nth r marks-end))))
+ (kill-buffer (current-buffer)))
+ (goto-char (post-kill-signature))
+ (insert-string "-- \n")
+ (insert sig)
+ (if (file-readable-p post-fixed-signature-source)
+ (insert-file-contents post-fixed-signature-source)
+ (insert "I really need a `post-fixed-signature-source'!\n")))))
+
+(defun post-select-signature-from-file ()
+ "*Interactively select a signature from `post-variable-signature-source'."
+ (interactive)
+ (setq post-select-signature-last-buffer (current-buffer))
+ (setq post-select-signature-last-point (point))
+ (pop-to-buffer "*Post-Select-Signature*")
+ (insert-file post-variable-signature-source)
+ (use-local-map post-select-signature-mode-map))
+
+(defun post-select-signature-select-sig-from-file ()
+ "*Chooses the signature the cursor is in from `post-variable-signature-source'."
+ (interactive)
+
+ ;; These 2 lines select whatever siglet the cursor is sitting in,
+ ;; making it nifty to C-s "word" then C-m (or whatever this is
+ ;; bound to).
+ (let ((sig-start (point))
+ (sig-end (point)))
+
+ (cond ((setq sig-start (search-backward-regexp post-signature-sep-regexp
+ nil "a"))
+ (forward-line 1)
+ (setq sig-start (point))))
+
+ (if (search-forward-regexp post-signature-sep-regexp nil "a")
+ (setq sig-end (match-beginning 0))
+ (setq sig-end (point-max)))
+
+ (let ((sig (buffer-substring-no-properties sig-start sig-end)))
+ (switch-to-buffer post-select-signature-last-buffer)
+ (goto-char (post-kill-signature))
+ (insert-string "-- \n")
+ (insert sig))
+ (if (file-readable-p post-fixed-signature-source)
+ (insert-file-contents post-fixed-signature-source))
+ (post-select-signature-quit)))
+
+(defun post-select-signature-from-dir ()
+ "Select a new signature for an email/post in the current buffer."
+ (interactive)
+ (setq post-select-signature-last-buffer (current-buffer))
+ (setq post-select-signature-last-point (point))
+ (pop-to-buffer "*Post-Select-Signature*")
+ (list-directory (concat post-signature-directory
+ post-signature-wildcard) t)
+ (pop-to-buffer "*Directory*")
+ (next-line 1)
+ (copy-to-buffer "*Post-Select-Signature*" (point) (point-max))
+ (kill-buffer "*Directory*")
+ (pop-to-buffer "*Post-Select-Signature*")
+ (use-local-map post-select-signature-mode-map)
+ (toggle-read-only t))
+
+(defun post-select-signature-select-sig-from-dir ()
+ "Set the signature in the calling buffer to the one under the cursor."
+ (interactive)
+ (let ((sig-start nil)
+ (sig-to-load nil))
+ (end-of-line)
+ (search-backward " ")
+ (forward-char)
+ (setq sig-start (point))
+ (end-of-line)
+ (setq sig-to-load (buffer-substring-no-properties sig-start (point)))
+ (switch-to-buffer post-select-signature-last-buffer)
+ (goto-char (post-kill-signature))
+ (insert-string "-- \n")
+ (insert-file (concat post-signature-directory sig-to-load))
+ (message "Signature set to %s%s" post-signature-directory sig-to-load)
+ (post-select-signature-quit)))
+
+(defun post-select-signature-quit ()
+ "Kill the *Post-Select-Signature* frame."
+ (interactive)
+ (kill-buffer "*Post-Select-Signature*")
+ (switch-to-buffer post-select-signature-last-buffer)
+ (goto-char post-select-signature-last-point)
+ (delete-other-windows))
+
+;;; Non-interactive functions
+
+(defun post-ask-for-address-with-default (header)
+ "Prompt for an email address, showing default.
+Argument HEADER the header type."
+ (let ((default (if (= (length (post-get-header-value header)) 0)
+ post-email-address
+ (post-get-header-value header))))
+ (read-string (concat header ": ") default)))
+
+; From davep@davep.org. RR hasn't tested it.
+(defun post-get-header-value (header)
+ "Get the value of a specific mail HEADER."
+ (save-excursion
+ (let ((value "")
+ (start-of-value nil))
+ (setf (point) (point-min))
+ (when (post-find-header-line header)
+ (setq start-of-value (point))
+ (end-of-line)
+ (setq value (buffer-substring-no-properties start-of-value (point))))
+ value)))
+
+;;; From davep@davep.org. RR hasn't tested it.
+(defun post-find-header-line (header)
+ "Find a HEADER line in the header."
+ (let ((old-point (point))
+ (end-of-header nil)
+ (found-point nil))
+ (setf (point) (point-min))
+ (search-forward-regexp "^$" nil t)
+ (setq end-of-header (point))
+ (setf (point) (point-min))
+ (cond ((search-forward-regexp (concat "^" header ": ") nil t)
+ (cond ((< (point) end-of-header)
+ (setq found-point (point)))
+ (t
+ (setf (point) old-point))))
+ (t
+ (setf (point) old-point)))
+ found-point))
+
+;;; Function to make a backup buffer for viewing the original.
+(defun post-copy-original ()
+ "Make a copy of the `post-mode' buffer before any editing by the user.
+This way they can refer back to this buffer during a compose session."
+ (copy-to-buffer (get-buffer-create "*Original*")
+ (point-min) (point-max)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; The Heart of Darkness
+;;;
+;;; The old post mode (i.e. Dave Pearson's) derived from mail-mode. I
+;;; prefer deriving from text mode like mutt mode did. - RR
+(define-derived-mode post-mode text-mode "Post"
+ "Major mode for composing email or news with an external agent.
+To customize it, type \\[customize] and select [Applications] [Mail] [Post].
+When you finish editing this message, type \\[post-save-current-buffer-and-exit] to save and exit Emacs.
+
+\\{post-mode-map}"
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Neat things to do right off the bat.
+
+ (auto-fill-mode (if post-uses-fill-mode 1 0))
+
+ (if post-backup-original (post-copy-original))
+
+ ;; Make Emacs smarter about wrapping citations and paragraphs.
+ ;; We probably can't handle Supercited messages, though.
+ (make-local-variable 'paragraph-start)
+ (make-local-variable 'paragraph-separate)
+ (setq paragraph-start
+ "\\([ \t\n\f]+[^ \t\n\f>]\\|[ \t\f>]*$\\)"
+ paragraph-separate
+ "[ \t\f>]*$")
+
+ ;; XEmacs needs easy-menu-add, Emacs does not care
+ (easy-menu-add post-mode-menu)
+
+ ;; If headers were passed, activate the necessary commands.
+ (when (looking-at "^[-A-Za-z0-9]+:")
+ (header-mode 1))
+
+ ;; Our temporary file lives in /tmp. Yuck! Compensate appropriately.
+ (make-local-variable 'backup-inhibited)
+ (setq backup-inhibited t)
+
+ (if (boundp 'font-lock-defaults)
+ (make-local-variable 'font-lock-defaults))
+ (flet ((add-syntax-highlight (face regexps)
+ (set face face)
+ (nconc post-font-lock-keywords
+ (loop for regexp in regexps
+ collect (list regexp (list 0 face 't))))))
+; collect (list regexp `(,0 ',face))))))
+ (add-syntax-highlight 'post-emoticon-face post-emoticon-pattern)
+ (add-syntax-highlight 'post-bold-face post-bold-pattern)
+ (add-syntax-highlight 'post-underline-face post-underline-pattern)
+ (add-syntax-highlight 'post-url-face post-url-pattern))
+ (setq font-lock-defaults
+ '(post-font-lock-keywords nil nil nil nil
+ (font-lock-syntactic-keywords
+ . post-font-lock-syntactic-keywords)
+ (font-lock-comment-face
+; . 'post-signature-text-face)))
+ . post-signature-text-face)))
+
+ ;; Force pwd to home directory if so required.
+ (cond (post-force-pwd-to-home
+ (cd "~")))
+
+ ;; Kill quoted sig if so required.
+ (cond (post-kill-quoted-sig
+ (post-delete-quoted-signatures)
+ (not-modified)))
+
+ ;; Remap signature selection functions according to whether the
+ ;; signatures are stored in a file or directory.
+ (if post-signature-source-is-file
+ (progn
+ (defalias 'post-select-signature 'post-select-signature-from-file)
+ (defalias 'post-select-signature-select-sig
+ 'post-select-signature-select-sig-from-file))
+ (progn
+ (defalias 'post-select-signature 'post-select-signature-from-dir)
+ (defalias 'post-select-signature-select-sig
+ 'post-select-signature-select-sig-from-dir)))
+
+ ;; Define mutt/slrn specific key bindings.
+ (define-key (current-local-map) "\C-c\C-b" 'post-make-region-bold)
+ (define-key (current-local-map) "\C-c\C-u" 'post-make-region-underlined)
+ (define-key (current-local-map) "\C-c\C-q" 'post-quote-region)
+ (define-key (current-local-map) "\C-c\C-d\C-q" 'post-unquote-region)
+ (define-key (current-local-map) "\C-c\C-a" 'post-attach-file)
+ (define-key (current-local-map) "\C-c\C-p" 'post-set-return-receipt-to)
+
+ ;; Give the buffer a handy name.
+ (if post-rename-buffer
+ (setq post-buf (rename-buffer "*Composing*" t)))
+
+ ;; If this is a news posting, check the length of the References field.
+ (if (post-references-p)
+ (header-check-references))
+
+ ;; Define the quote signs as comments to make comment-region usable.
+ (make-local-variable 'comment-start)
+ (setq comment-start post-quote-start)
+
+ ;; Run any hooks.
+ (run-hooks 'post-mode-hook)
+
+ ;; Jump past header if so required.
+ (cond (post-jump-header
+ (post-goto-body)))
+
+ (unless (fboundp 'server-process-filter)
+ (message (substitute-command-keys
+ "Type \\[describe-mode] for help composing; \\[post-save-current-buffer-and-exit] when done."))))
+
+(defun post-references-p ()
+ "Is there a References header in this buffer?"
+ (save-excursion
+ (goto-char (point-min))
+ (looking-at "^References: ")))
+
+(defun post-body-says-attach ()
+ "Check if attach appears in the body."
+ (post-goto-body)
+
+ ;; Aargh it's annoying that how-many returns a string,
+ ;; "13 occurences" instead of a number, 13.
+ (let ((total-attach (string-to-int (how-many post-attachment-regexp))))
+ ;; And this mess is just to catch the unlikely false alarm of
+ ;; "attach" being in the signature, but not in the body.
+ (if (> total-attach 0)
+ (progn (post-goto-signature)
+ (> total-attach (string-to-int (how-many
+ post-attachment-regexp)))))))
+
+(defun post-prompt-for-attachment ()
+ "Prompt for an attachment."
+ (if (y-or-n-p "Do you want to attach anything? ")
+ (let ((file (read-file-name "Attach file: " nil nil t nil))
+ (description (string-read "Description: ")))
+ (header-attach-file file description))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Post Header Mode
+
+(defvar header-mode nil)
+
+(defun header-mode (&optional arg)
+ "Commands for editing the header of an e-mail or news message.
+
+\\{header-mode-map}
+Optional argument ARG ."
+
+ (interactive "P")
+ (make-local-variable 'header-mode)
+ (setq header-mode
+ (if (null arg)
+ (not header-mode)
+ (> (prefix-numeric-value arg) 0)))
+ (setq post-has-attachment nil)
+
+ ;; XEmacs needs easy-menu-add, Emacs does not care
+ (easy-menu-add header-mode-menu)
+
+ (force-mode-line-update))
+
+(defvar header-mode-map (make-sparse-keymap)
+ "Keymap used for editing RFC822 header.")
+
+(defun header-position-on-value ()
+ "Go to the start of the value part of a header."
+ (beginning-of-line)
+ (skip-chars-forward "-A-Za-z0-9:")
+ ;; XXX - Should make sure we stay on line.
+ (forward-char)
+ (point))
+
+(defun header-goto-field (field)
+ "Go to FIELD of a header."
+ (let ((case-fold-search t))
+ (goto-char (point-min))
+ (save-match-data
+ (when (re-search-forward (concat "^\\($\\|" field ": \\)"))
+ (if (looking-at "^$")
+ (progn
+ (insert-string field ": \n")
+ (forward-char -1))
+ (header-position-on-value))))))
+
+(defmacro define-header-goto (name header)
+ "Define functions called NAME to go to HEADER."
+ `(defun ,name ()
+ ,(concat "Position the cursor on the " header ": header.")
+ (interactive)
+ (header-goto-field ,header)))
+
+(define-header-goto header-goto-to "To")
+(define-header-goto header-goto-cc "Cc")
+(define-header-goto header-goto-fcc "Fcc")
+(define-header-goto header-goto-summary "Summary")
+(define-header-goto header-goto-keywords "Keywords")
+(define-header-goto header-goto-subject "Subject")
+(define-header-goto header-goto-bcc "Bcc")
+(define-header-goto header-goto-reply-to "Reply-To")
+(define-header-goto header-goto-from "From")
+(define-header-goto header-goto-organization "Organization")
+
+(defun header-attach-file (file description)
+ "Attach a FILE to the current message (works with Mutt).
+Argument DESCRIPTION MIME description."
+ (interactive "fAttach file: \nsDescription: ")
+ (when (> (length file) 0)
+ (save-excursion
+ (save-match-data
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (search-forward-regexp "^$")
+ (insert-string (concat "Attach: " (file-truename file) " "
+ description "\n"))
+ (message (concat "Attached '" file "'."))
+ (setq post-has-attachment t))))))
+
+(or (assq 'header-mode minor-mode-alist)
+ (setq minor-mode-alist
+ (cons '(header-mode " Header") minor-mode-alist)))
+
+(or (assq 'header-mode minor-mode-map-alist)
+ (setq minor-mode-map-alist
+ (cons (cons 'header-mode header-mode-map)
+ minor-mode-map-alist)))
+
+(defun header-set-return-receipt-to (address)
+ "Insert a Return-Receipt-To header into an email.
+Argument ADDRESS email address return receipts should be sent to."
+ (interactive (list (post-ask-for-address-with-default "Return-Receipt-To")))
+ (save-excursion
+ (header-set-value "Return-Receipt-To" address)))
+
+(defun post-news-posting-p ()
+ "Does the buffer look like a news posting?"
+ (save-excursion
+ (setf (point) (point-min))
+ (looking-at "^Newsgroups: ")))
+
+(defun header-set-followup-to (to)
+ "Set the Followup-To: header.
+Argument TO Where followups should go."
+ (interactive (list (header-ask-for-value "Followup-To"
+ (header-ask-for-value
+ "Newsgroups"))))
+ (cond ((post-news-posting-p)
+ (save-excursion
+ (header-set-value "Followup-To" to)))
+ (t
+ (error
+ "Followup-To is for Usenet. Maybe you want Reply-To or Mail-Followup-To"))))
+
+(defun header-set-organization (org)
+ "Set the Organization: header.
+Argument ORG Should be SMERSH."
+ (interactive (list (header-ask-for-value "Organization")))
+ (save-excursion
+ (header-set-value "Organization" org)))
+
+(defun header-check-references ()
+ "Place the cursor at the start of the References: if they are too long."
+ (interactive)
+ (cond ((> (header-references-length) 500) ; 500 to be on the safe side.
+ (beep) ; Catch my attention.
+ (goto-char (point-min))
+ (search-forward-regexp "^References: " nil t))))
+
+(defun header-references-length (&optional show)
+ "Get (and optionally display) the length of the references header.
+Optional argument SHOW Whether or not to display the length."
+ (interactive)
+ (let* ((header "References")
+ (refs (header-get-value header))
+ (len (+ (length header) (length refs) 2)))
+ (if (or (interactive-p) show)
+ (message "References header is %d characters in length." len))
+ len))
+
+(defun header-delete-reference ()
+ "Delete the first reference in the references header."
+ (interactive)
+ (save-excursion
+ (let ((ref-location (header-goto-field "References")))
+ (cond (ref-location
+ (let ((ref-start (goto-char ref-location)))
+ (cond ((search-forward ">" nil t)
+ (forward-char 1)
+ (delete-region ref-start (point))
+ (header-references-length t)))))))))
+
+;; Noninteractive functions.
+
+(defun header-ask-for-value (header &optional default)
+ "Ask for a HEADER value, defaulting to the current value if one is present.
+Optional argument DEFAULT ."
+ (let ((new-value (post-get-header-value header)))
+ (and (= (length new-value) 0)
+ default
+ (setq new-value default))
+ (read-string (concat header ": ") new-value)))
+
+(defun header-get-value (header)
+ "Get the value of a specific mail HEADER."
+ (save-excursion
+ (let ((value "")
+ (start-of-value nil))
+ (goto-char (point-min))
+ (cond ((post-find-header-line header)
+ (setq start-of-value (point))
+ (end-of-line)
+ (setq value (buffer-substring-no-properties
+ start-of-value (point)))))
+ value)))
+
+(defun header-set-value (header value)
+ "Set VALUE of a HEADER (replacing any existing value)."
+ (let ((kill-ring kill-ring))
+ (setf (point) (point-min))
+ (cond ((post-find-header-line header)
+ (beginning-of-line)
+ (kill-line)
+ (insert-string (concat header ": " value)))
+ (t
+ (header-append-value header value))))
+ (message "%s set to %s" header value))
+
+(defun header-append-value (header value)
+ "Add a HEADER and set it's VALUE (if header exists, will add multiple headers)."
+ (goto-char (point-min))
+ (search-forward-regexp "^$" nil t)
+ (insert-string (concat header ": " value "\n")))
+
+;;; Setup the mode map for the select-signature buffer.
+(if post-select-signature-mode-map nil
+ (setq post-select-signature-mode-map (make-sparse-keymap))
+ (define-key post-select-signature-mode-map "\C-m"
+ 'post-select-signature-select-sig)
+ (define-key post-select-signature-mode-map " "
+ 'post-select-signature-select-sig)
+ (define-key post-select-signature-mode-map "q" 'post-select-signature-quit)
+ (define-key post-select-signature-mode-map "\C-g"
+ 'post-select-signature-quit))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Key Bindings
+
+(define-key post-mode-map "\C-c\C-c" 'post-save-current-buffer-and-exit)
+(define-key post-mode-map "\C-c\C-d\C-s" 'post-delete-quoted-signatures)
+(define-key post-mode-map "\C-c\C-d\C-c" 'post-delete-old-citations)
+(define-key post-mode-map "\C-c\C-t" 'post-goto-body)
+(define-key post-mode-map "\C-c\C-e" 'post-goto-signature)
+(define-key post-mode-map "\C-c\C-r" 'post-random-signature)
+(define-key post-mode-map "\C-c\C-b" 'post-make-region-bold)
+(define-key post-mode-map "\C-c\C-u" 'post-make-region-underlined)
+(define-key post-mode-map "\C-c\C-q" 'post-quote-region)
+(define-key post-mode-map "\C-c\C-d\C-q" 'post-unquote-region)
+(define-key post-mode-map "\C-c\C-s" 'post-select-signature)
+
+(define-key header-mode-map "\C-c\C-f\C-t" 'header-goto-to)
+(define-key header-mode-map "\C-c\C-f\C-c" 'header-goto-cc)
+(define-key header-mode-map "\C-c\C-f\C-w" 'header-goto-fcc)
+(define-key header-mode-map "\C-c\C-f\C-u" 'header-goto-summary)
+(define-key header-mode-map "\C-c\C-f\C-k" 'header-goto-keywords)
+(define-key header-mode-map "\C-c\C-f\C-s" 'header-goto-subject)
+(define-key header-mode-map "\C-c\C-f\C-b" 'header-goto-bcc)
+(define-key header-mode-map "\C-c\C-f\C-r" 'header-goto-reply-to)
+(define-key header-mode-map "\C-c\C-f\C-f" 'header-goto-from)
+(define-key header-mode-map "\C-c\C-f\C-o" 'header-goto-organization)
+(define-key header-mode-map "\C-c\C-ff" 'header-set-followup-to)
+(define-key header-mode-map "\C-c\C-a" 'header-attach-file)
+(define-key header-mode-map "\C-c\C-fd" 'header-delete-reference)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Menus
+
+(easy-menu-define
+ post-mode-menu post-mode-map "Post Message Composition Commands."
+ '("Post"
+ ["Delete quoted signatures" post-delete-quoted-signatures t]
+ ["Delete doubly quoted text" post-delete-old-citations t]
+ "----"
+ ["Go to body of message" post-goto-body t]
+ ["Go to signature of message" post-goto-signature t]
+ ["Get new random signature" post-random-signature t]
+ ["Select new signature" post-select-signature t]
+ "----"
+ ["Embolden region" post-make-region-bold t]
+ ["Underline region" post-make-region-underlined t]
+ "----"
+ ["Quote region" post-quote-region t]
+ ["Unquote region" post-unquote-region t]
+ "----"
+ ["Save message and return from Post" post-save-current-buffer-and-exit t]))
+
+(easy-menu-define
+ header-mode-menu header-mode-map "Header Editing Commands."
+ '("Header"
+ ["Attach File..." header-attach-file t]
+ "----"
+ ["Edit From Header" header-goto-from t]
+ ["Edit Subject Header" header-goto-subject t]
+ ["Edit To Header" header-goto-to t]
+ ["Edit Cc Header" header-goto-cc t]
+ ["Edit Bcc Header" header-goto-bcc t]
+ ["Edit Fcc Header" header-goto-fcc t]
+ ["Edit Reply-To Header" header-goto-reply-to t]
+ ["Edit Summary Header" header-goto-summary t]
+ ["Edit Keywords Header" header-goto-keywords t]
+ ["Edit Organization Header" header-goto-organization t]))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Finish Installing Post Mode
+
+(when post-insert-to-auto-mode-alist-on-load
+ (unless (assq post-mail-message auto-mode-alist)
+ (setq auto-mode-alist
+ (cons (cons post-mail-message 'post-mode)
+ auto-mode-alist)))
+ (unless (assq post-news-posting auto-mode-alist)
+ (setq auto-mode-alist
+ (cons (cons post-news-posting 'post-mode)
+ auto-mode-alist))))
+
+(provide 'post)
+
+;;; post.el ends here
--- /dev/null
+;;; psvn.el --- Subversion interface for emacs
+;; Copyright (C) 2002-2004 by Stefan Reichoer
+
+;; Author: Stefan Reichoer, <stefan@xsteve.at>
+;; $Id: psvn.el 10983 2004-09-15 18:38:26Z xsteve $
+
+;; psvn.el is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; psvn.el is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary
+
+;; psvn.el is tested with GNU Emacs 21.3 on windows, debian linux,
+;; freebsd5 with svn 1.05
+
+;; psvn.el is an interface for the revision control tool subversion
+;; (see http://subversion.tigris.org)
+;; psvn.el provides a similar interface for subversion as pcl-cvs for cvs.
+;; At the moment the following commands are implemented:
+;; M-x svn-status: run 'svn -status -v'
+;; and show the result in the *svn-status* buffer. This buffer uses
+;; svn-status mode in which the following keys are defined:
+;; g - svn-status-update: run 'svn status -v'
+;; C-u g - svn-status-update: run 'svn status -vu'
+;; = - svn-status-show-svn-diff run 'svn diff'
+;; l - svn-status-show-svn-log run 'svn log'
+;; i - svn-status-info run 'svn info'
+;; r - svn-status-revert run 'svn revert'
+;; V - svn-status-resolved run 'svn resolved'
+;; U - svn-status-update-cmd run 'svn update'
+;; c - svn-status-commit-file run 'svn commit'
+;; a - svn-status-add-file run 'svn add --non-recursive'
+;; A - svn-status-add-file-recursively run 'svn add'
+;; + - svn-status-make-directory run 'svn mkdir'
+;; R - svn-status-mv run 'svn mv'
+;; C-d - svn-status-rm run 'svn rm'
+;; M-c - svn-status-cleanup run 'svn cleanup'
+;; b - svn-status-blame run 'svn blame'
+;; RET - svn-status-find-file-or-examine-directory
+;; ^ - svn-status-examine-parent
+;; ~ - svn-status-get-specific-revision
+;; E - svn-status-ediff-with-revision
+;; s - svn-status-show-process-buffer
+;; e - svn-status-toggle-edit-cmd-flag
+;; ? - svn-status-toggle-hide-unknown
+;; _ - svn-status-toggle-hide-unmodified
+;; m - svn-status-set-user-mark
+;; u - svn-status-unset-user-mark
+;; $ - svn-status-toggle-elide
+;; DEL - svn-status-unset-user-mark-backwards
+;; * ! - svn-status-unset-all-usermarks
+;; * ? - svn-status-mark-unknown
+;; * A - svn-status-mark-added
+;; * M - svn-status-mark-modified
+;; . - svn-status-goto-root-or-return
+;; f - svn-status-find-file
+;; o - svn-status-find-file-other-window
+;; v - svn-status-view-file-other-window
+;; I - svn-status-parse-info
+;; P l - svn-status-property-list
+;; P s - svn-status-property-set
+;; P d - svn-status-property-delete
+;; P e - svn-status-property-edit-one-entry
+;; P i - svn-status-property-ignore-file
+;; P I - svn-status-property-ignore-file-extension
+;; P C-i - svn-status-property-edit-svn-ignore
+;; P k - svn-status-property-set-keyword-list
+;; P y - svn-status-property-set-eol-style
+;; h - svn-status-use-history
+;; q - svn-status-bury-buffer
+
+;; To use psvn.el put the following line in your .emacs:
+;; (require 'psvn)
+;; Start the svn interface with M-x svn-status
+
+;; The latest version of psvn.el can be found at:
+;; http://www.xsteve.at/prg/emacs/psvn.el
+;; Or you can check it out from the subversion repository:
+;; svn co http://svn.collab.net/repos/svn/trunk/contrib/client-side/psvn psvn
+
+;; TODO:
+;; * shortcut for svn propset svn:keywords "Date" psvn.el
+;; * docstrings for the functions
+;; * perhaps shortcuts for ranges, dates
+;; * when editing the command line - offer help from the svn client
+;; * finish svn-status-property-set
+;; * eventually use the customize interface
+;; * interactive svn-status should complete existing directories only;
+;; unfortunately `read-directory-name' doesn't exist in Emacs 21.3
+;; * Add repository browser
+;; * Improve support for svn blame
+;; * Support for editing the log file entries, e.g.:
+;; svn propedit --revprop -r9821 svn:log
+;; * Better logview mode (allow to show the changeset for a given entry)
+
+;; Overview over the implemented/not (yet) implemented svn sub-commands:
+;; * add implemented
+;; * blame implemented
+;; * cat implemented
+;; * checkout (co)
+;; * cleanup implemented
+;; * commit (ci) implemented
+;; * copy (cp)
+;; * delete (del, remove, rm) implemented
+;; * diff (di) implemented
+;; * export
+;; * help (?, h)
+;; * import
+;; * info implemented
+;; * list (ls)
+;; * log implemented
+;; * merge
+;; * mkdir implemented
+;; * move (mv, rename, ren) implemented
+;; * propdel (pdel) implemented
+;; * propedit (pedit, pe) not needed
+;; * propget (pget, pg) used
+;; * proplist (plist, pl) implemented
+;; * propset (pset, ps) used
+;; * resolved implemented
+;; * revert implemented
+;; * status (stat, st) implemented
+;; * switch (sw)
+;; * update (up) implemented
+
+;; For the not yet implemented commands you should use the command line
+;; svn client. If there are user requests for any missing commands I will
+;; probably implement them.
+
+;; Comments / suggestions and bug reports are welcome!
+
+;;; Code:
+
+;;; user setable variables
+(defvar svn-log-edit-file-name "++svn-log++" "*Name of a saved log file.")
+(defvar svn-status-hide-unknown nil "*Hide unknown files in *svn-status* buffer.")
+(defvar svn-status-hide-unmodified nil "*Hide unmodified files in *svn-status* buffer.")
+(defvar svn-status-directory-history nil "*List of visited svn working directories.")
+
+(defvar svn-status-unmark-files-after-list '(commit revert)
+ "*List of operations after which all user marks will be removed.
+Possible values are: commit, revert.")
+
+;;; default arguments to pass to svn commands
+(defvar svn-status-default-log-arguments ""
+ "*Arguments to pass to svn log.
+\(used in `svn-status-show-svn-log'; override these by giving prefixes\).")
+
+;;; hooks
+(defvar svn-log-edit-mode-hook nil "Hook run when entering `svn-log-edit-mode'.")
+
+(defvar svn-status-wash-control-M-in-process-buffers
+ (eq system-type 'windows-nt)
+ "*Remove any trailing ^M from the *svn-process* buffer.")
+
+;;; Customize group
+(defgroup psvn nil
+ "Subversion interface for Emacs."
+ :group 'tools)
+
+(defgroup psvn-faces nil
+ "psvn faces."
+ :group 'psvn)
+
+
+(eval-and-compile
+ (require 'cl)
+ (defconst svn-xemacsp (featurep 'xemacs))
+ (if svn-xemacsp
+ (require 'overlay)
+ (require 'overlay nil t)))
+
+;; Use the normally used mode for files ending in .~HEAD~, .~BASE~, ...
+(add-to-list 'auto-mode-alist '("\\.~?\\(HEAD\\|BASE\\|PREV\\)~?\\'" ignore t))
+
+;;; internal variables
+(defvar svn-process-cmd nil)
+(defvar svn-status-info nil)
+(defvar svn-status-base-info nil)
+(defvar svn-status-initial-window-configuration nil)
+(defvar svn-status-default-column 23)
+(defvar svn-status-default-revision-width 4)
+(defvar svn-status-default-author-width 9)
+(defvar svn-status-line-format " %c%c %4s %4s %-9s")
+(defvar svn-status-short-mod-flag-p t)
+(defvar svn-start-of-file-list-line-number 0)
+(defvar svn-status-files-to-commit nil)
+(defvar svn-status-pre-commit-window-configuration nil)
+(defvar svn-status-pre-propedit-window-configuration nil)
+(defvar svn-status-head-revision nil)
+(defvar svn-status-root-return-info nil)
+(defvar svn-status-property-edit-must-match-flag nil)
+(defvar svn-status-propedit-property-name nil)
+(defvar svn-status-propedit-file-list nil)
+(defvar svn-status-mode-line-process "")
+(defvar svn-status-mode-line-process-status "")
+(defvar svn-status-mode-line-process-edit-flag "")
+(defvar svn-status-edit-svn-command nil)
+(defvar svn-status-update-previous-process-output nil)
+(defvar svn-status-temp-dir
+ (or
+ (when (boundp 'temporary-file-directory) temporary-file-directory) ;emacs
+ (when (boundp 'temp-directory) temp-directory) ;xemacs
+ "/tmp/"))
+(defvar svn-temp-suffix (make-temp-name "."))
+(defvar svn-status-temp-file-to-remove nil)
+(defvar svn-status-temp-arg-file (concat svn-status-temp-dir "svn.arg" svn-temp-suffix))
+
+;;; faces
+(defface svn-status-marked-face
+ '((((type tty) (class color)) (:foreground "green" :weight light))
+ (((class color) (background light)) (:foreground "green3"))
+ (((class color) (background dark)) (:foreground "palegreen2"))
+ (t (:weight bold)))
+ "Face to highlight the mark for user marked files in svn status buffers."
+ :group 'psvn-faces)
+
+(defface svn-status-modified-external-face
+ '((((type tty) (class color)) (:foreground "magenta" :weight light))
+ (((class color) (background light)) (:foreground "magenta"))
+ (((class color) (background dark)) (:foreground "yellow"))
+ (t (:weight bold)))
+ "Face to highlight the phrase \"externally modified\" in *svn-status* buffers."
+ :group 'psvn-faces)
+
+;based on cvs-filename-face
+(defface svn-status-directory-face
+ '((((type tty) (class color)) (:foreground "lightblue" :weight light))
+ (((class color) (background light)) (:foreground "blue4"))
+ (((class color) (background dark)) (:foreground "lightskyblue1"))
+ (t (:weight bold)))
+ "Face for directories in svn status buffers.
+See `svn-status--line-info->directory-p' for what counts as a directory."
+ :group 'psvn-faces)
+
+;based on font-lock-comment-face
+(defface svn-status-filename-face
+ '((((class color) (background light)) (:foreground "chocolate"))
+ (((class color) (background dark)) (:foreground "beige")))
+ "Face for non-directories in svn status buffers.
+See `svn-status--line-info->directory-p' for what counts as a directory."
+ :group 'psvn-faces)
+
+(defvar svn-highlight t)
+;; stolen from PCL-CVS
+(defun svn-add-face (str face &optional keymap)
+ (when svn-highlight
+ ;; Do not use `list*'; cl.el might not have been loaded. We could
+ ;; put (require 'cl) at the top but let's try to manage without.
+ (add-text-properties 0 (length str)
+ `(face ,face
+ ,@(when keymap
+ `(mouse-face highlight
+ local-map ,keymap)))
+ str))
+ str)
+
+(defun svn-status-maybe-add-face (condition text face)
+ "If CONDITION then add FACE to TEXT.
+Else return TEXT unchanged."
+ (if condition
+ (svn-add-face text face)
+ text))
+
+(defun svn-status-choose-face-to-add (condition text face1 face2)
+ "If CONDITION then add FACE1 to TEXT, else add FACE2 to TEXT."
+ (if condition
+ (svn-add-face text face1)
+ (svn-add-face text face2)))
+
+; compatibility
+; emacs 20
+(unless (fboundp 'point-at-eol) (defalias 'point-at-eol 'line-end-position))
+(unless (fboundp 'point-at-bol) (defalias 'point-at-bol 'line-beginning-position))
+(unless (functionp 'read-directory-name) (defalias 'read-directory-name 'read-file-name))
+
+(eval-when-compile
+ (if (not (fboundp 'gethash))
+ (require 'cl-macs)))
+(if (not (fboundp 'puthash))
+ (defalias 'puthash 'cl-puthash))
+
+(defvar svn-status-display-new-status-buffer nil)
+;;;###autoload
+(defun svn-status (dir &optional arg)
+ "Examine the status of Subversion working copy in directory DIR.
+If ARG then pass the -u argument to `svn status'."
+ (interactive (list (read-directory-name "SVN status directory: "
+ nil default-directory nil)))
+ (unless (file-directory-p dir)
+ (error "%s is not a directory" dir))
+ (if (not (file-exists-p (concat dir "/.svn/")))
+ (when (y-or-n-p
+ (concat dir
+ " does not seem to be a Subversion working copy (no .svn directory). "
+ "Run dired instead? "))
+ (dired dir))
+ (setq dir (file-name-as-directory dir))
+ (setq svn-status-directory-history (delete dir svn-status-directory-history))
+ (add-to-list 'svn-status-directory-history dir)
+ (if (string= (buffer-name) "*svn-status*")
+ (setq svn-status-display-new-status-buffer nil)
+ (setq svn-status-display-new-status-buffer t)
+ ;;(message "psvn: Saving initial window configuration")
+ (setq svn-status-initial-window-configuration (current-window-configuration)))
+ (let* ((status-buf (get-buffer-create "*svn-status*"))
+ (proc-buf (get-buffer-create "*svn-process*")))
+ (save-excursion
+ (set-buffer status-buf)
+ (setq default-directory dir)
+ (set-buffer proc-buf)
+ (setq default-directory dir)
+ (if arg
+ (svn-run-svn t t 'status "status" "-vu")
+ (svn-run-svn t t 'status "status" "-v"))))))
+
+(defun svn-status-use-history ()
+ (interactive)
+ (let* ((hist svn-status-directory-history)
+ (dir (read-from-minibuffer "svn-status on directory: "
+ (cadr svn-status-directory-history)
+ nil nil 'hist)))
+ (when (file-directory-p dir)
+ (svn-status dir))))
+
+(defun svn-run-svn (run-asynchron clear-process-buffer cmdtype &rest arglist)
+ "Run svn with arguments ARGLIST.
+
+If RUN-ASYNCHRON is t then run svn asynchronously.
+
+If CLEAR-PROCESS-BUFFER is t then erase the contents of the
+*svn-process* buffer before commencing.
+
+CMDTYPE is a symbol such as 'mv, 'revert, or 'add, representing the
+command to run.
+
+ARGLIST is a list of arguments \(which must include the command name,
+for example: '(\"revert\" \"file1\"\)"
+ (if (eq (process-status "svn") nil)
+ (progn
+ (when svn-status-edit-svn-command
+ (setq arglist (append arglist
+ (split-string
+ (read-from-minibuffer
+ (format "svn %s %S " cmdtype arglist)))))
+ (when (eq svn-status-edit-svn-command t)
+ (svn-status-toggle-edit-cmd-flag t))
+ (message "svn-run-svn %s: %S" cmdtype arglist))
+ (let* ((proc-buf (get-buffer-create "*svn-process*"))
+ (svn-proc))
+ (when (listp (car arglist))
+ (setq arglist (car arglist)))
+ (save-excursion
+ (set-buffer proc-buf)
+ (setq buffer-read-only nil)
+ (fundamental-mode)
+ (if clear-process-buffer
+ (delete-region (point-min) (point-max))
+ (goto-char (point-max)))
+ (setq svn-process-cmd cmdtype)
+ (setq svn-status-mode-line-process-status (format " running %s" cmdtype))
+ (svn-status-update-mode-line)
+ (sit-for 0.1)
+ (if run-asynchron
+ (progn
+ (setq svn-proc (apply 'start-process "svn" proc-buf "svn" arglist))
+ (set-process-sentinel svn-proc 'svn-process-sentinel))
+ ;;(message "running synchron: svn %S" arglist)
+ (apply 'call-process "svn" nil proc-buf nil arglist)
+ (setq svn-status-mode-line-process-status "")
+ (svn-status-update-mode-line)))))
+ (error "You can only run one svn process at once!")))
+
+(defun svn-process-sentinel (process event)
+ ;;(princ (format "Process: %s had the event `%s'" process event)))
+ ;;(save-excursion
+ (let ((act-buf (current-buffer)))
+ (set-buffer (process-buffer process))
+ (setq svn-status-mode-line-process-status "")
+ (svn-status-update-mode-line)
+ (cond ((string= event "finished\n")
+ (cond ((eq svn-process-cmd 'status)
+ ;;(message "svn status finished")
+ (if (eq system-type 'windows-nt)
+ ;; convert path separator as UNIX style
+ (save-excursion
+ (goto-char (point-min))
+ (while (search-forward "\\" nil t)
+ (replace-match "/"))))
+ (svn-parse-status-result)
+ (set-buffer act-buf)
+ (svn-status-update-buffer)
+ (when svn-status-update-previous-process-output
+ (set-buffer (process-buffer process))
+ (delete-region (point-min) (point-max))
+ (insert "Output from svn command:\n")
+ (insert svn-status-update-previous-process-output)
+ (goto-char (point-min))
+ (setq svn-status-update-previous-process-output nil))
+ (when svn-status-display-new-status-buffer
+ (set-window-configuration svn-status-initial-window-configuration)
+ (switch-to-buffer "*svn-status*")))
+ ((eq svn-process-cmd 'log)
+ (svn-status-show-process-buffer-internal t)
+ (pop-to-buffer "*svn-process*")
+ (switch-to-buffer (get-buffer-create "*svn-log*"))
+ (let ((buffer-read-only nil))
+ (delete-region (point-min) (point-max))
+ (insert-buffer-substring "*svn-process*"))
+ (svn-log-view-mode)
+ (goto-char (point-min))
+ (forward-line 3)
+ (font-lock-fontify-buffer)
+ (message "svn log finished"))
+ ((eq svn-process-cmd 'info)
+ (svn-status-show-process-buffer-internal t)
+ (message "svn info finished"))
+ ((eq svn-process-cmd 'parse-info)
+ (svn-status-parse-info-result))
+ ((eq svn-process-cmd 'blame)
+ (svn-status-show-process-buffer-internal t)
+ (message "svn blame finished"))
+ ((eq svn-process-cmd 'commit)
+ (svn-status-remove-temp-file-maybe)
+ (svn-status-show-process-buffer-internal t)
+ (when (member 'commit svn-status-unmark-files-after-list)
+ (svn-status-unset-all-usermarks))
+ (svn-status-update)
+ (message "svn commit finished"))
+ ((eq svn-process-cmd 'update)
+ (svn-status-show-process-buffer-internal t)
+ (svn-status-update)
+ (message "svn update finished"))
+ ((eq svn-process-cmd 'add)
+ (svn-status-update)
+ (message "svn add finished"))
+ ((eq svn-process-cmd 'mkdir)
+ (svn-status-update)
+ (message "svn mkdir finished"))
+ ((eq svn-process-cmd 'revert)
+ (when (member 'revert svn-status-unmark-files-after-list)
+ (svn-status-unset-all-usermarks))
+ (svn-status-update)
+ (message "svn revert finished"))
+ ((eq svn-process-cmd 'resolved)
+ (svn-status-update)
+ (message "svn resolved finished"))
+ ((eq svn-process-cmd 'mv)
+ (svn-status-update)
+ (message "svn mv finished"))
+ ((eq svn-process-cmd 'rm)
+ (svn-status-update)
+ (message "svn rm finished"))
+ ((eq svn-process-cmd 'cleanup)
+ (message "svn cleanup finished"))
+ ((eq svn-process-cmd 'proplist)
+ (svn-status-show-process-buffer-internal t)
+ (message "svn proplist finished"))
+ ((eq svn-process-cmd 'proplist-parse)
+ (svn-status-property-parse-property-names))
+ ((eq svn-process-cmd 'propset)
+ (svn-status-remove-temp-file-maybe)
+ (svn-status-update))
+ ((eq svn-process-cmd 'propdel)
+ (svn-status-update))))
+ ((string= event "killed\n")
+ (message "svn process killed"))
+ ((string-match "exited abnormally" event)
+ (while (accept-process-output process 0 100))
+ ;; find last error message and show it.
+ (goto-char (point-max))
+ (message "svn failed: %s"
+ (if (re-search-backward "^svn: \\(.*\\)" nil t)
+ (match-string 1)
+ event)))
+ (t
+ (message "svn process had unknown event: %s" event))
+ (svn-status-show-process-buffer-internal t))))
+
+(defun svn-parse-rev-num (str)
+ (if (and str (stringp str)
+ (save-match-data (string-match "^[0-9]+" str)))
+ (string-to-number str)
+ -1))
+
+
+(defun svn-parse-status-result ()
+ "Parse the *svn-process* buffer.
+The results are used to build the `svn-status-info' variable."
+ (setq svn-status-head-revision nil)
+ (save-excursion
+ (let ((old-ui-information (svn-status-ui-information-hash-table))
+ (line-string)
+ (user-mark)
+ (svn-marks)
+ (svn-file-mark)
+ (svn-property-mark)
+ (svn-update-mark)
+ (local-rev)
+ (last-change-rev)
+ (author)
+ (path)
+ (user-elide nil)
+ (ui-status '(nil nil)) ; contains (user-mark user-elide)
+ (revision-width svn-status-default-revision-width)
+ (author-width svn-status-default-author-width))
+ (set-buffer "*svn-process*")
+ (setq svn-status-info nil)
+ (goto-char (point-min))
+ (while (< (point) (point-max))
+ (cond
+ ((= (point-at-eol) (point-at-bol)) ;skip blank lines
+ nil)
+ ((looking-at "Status against revision:[ ]+\\([0-9]+\\)")
+ ;; the above message appears for the main listing plus once for each svn:externals entry
+ (unless svn-status-head-revision
+ (setq svn-status-head-revision (match-string 1))))
+ ((looking-at "Performing status on external item at '\(.*\)'")
+ ;; The *next* line has info about the directory named in svn:externals
+ ;; we should parse it, and merge the info with what we have already know
+ ;; but for now just ignore the line completely
+ (forward-line)
+ )
+ (t
+ (setq svn-marks (buffer-substring (point) (+ (point) 8))
+ svn-file-mark (elt svn-marks 0) ; 1st column
+ svn-property-mark (elt svn-marks 1) ; 2nd column
+ ;;svn-locked-mark (elt svn-marks 2) ; 3rd column
+ ;;svn-added-with-history-mark (elt svn-marks 3); 4th column
+ ;;svn-switched-mark (elt svn-marks 4) ; 5th column
+ svn-update-mark (elt svn-marks 7)) ; 8th column
+
+ (when (eq svn-property-mark ?\ ) (setq svn-property-mark nil))
+ (when (eq svn-update-mark ?\ ) (setq svn-update-mark nil))
+ (forward-char 8)
+ (skip-chars-forward " ")
+ (cond
+ ((looking-at "\\([-?]\\|[0-9]+\\) +\\([-?]\\|[0-9]+\\) +\\([^ ]+\\) *\\(.+\\)")
+ (setq local-rev (svn-parse-rev-num (match-string 1))
+ last-change-rev (svn-parse-rev-num (match-string 2))
+ author (match-string 3)
+ path (match-string 4)))
+ ((looking-at "\\(.*\\)")
+ (setq path (match-string 1)
+ local-rev -1
+ last-change-rev -1
+ author (if (eq svn-file-mark 88) "" "?"))) ;clear author of svn:externals dirs
+ (t
+ (error "Unknown status line format")))
+ (unless path (setq path "."))
+ (setq ui-status (or (gethash path old-ui-information) (list user-mark user-elide)))
+ (setq svn-status-info (cons (list ui-status
+ svn-file-mark
+ svn-property-mark
+ path
+ local-rev
+ last-change-rev
+ author
+ svn-update-mark)
+ svn-status-info))
+ (setq revision-width (max revision-width
+ (length (number-to-string local-rev))
+ (length (number-to-string last-change-rev))))
+ (setq author-width (max author-width (length author)))))
+ (forward-line 1))
+ ;; With subversion 0.29.0 and above, `svn -u st' returns files in
+ ;; a random order (especially if we have a mixed revision wc)
+ (setq svn-status-default-column
+ (+ 6 revision-width revision-width author-width
+ (if svn-status-short-mod-flag-p 3 0)))
+ (setq svn-status-line-format (format " %%c%%c %%%ds %%%ds %%-%ds"
+ revision-width
+ revision-width
+ author-width))
+ (setq svn-status-info (sort svn-status-info 'svn-status-sort-predicate)))))
+
+;;(string-lessp "." "%") => nil
+;(svn-status-sort-predicate '(t t t ".") '(t t t "%")) => t
+(defun svn-status-sort-predicate (a b)
+ "Return t if A should appear before B in the *svn-status* buffer.
+A and B must be line-info's."
+ (string-lessp (concat (svn-status-line-info->full-path a) "/")
+ (concat (svn-status-line-info->full-path b) "/")))
+
+(defun svn-status-remove-temp-file-maybe ()
+ "Remove any (no longer required) temporary files created by psvn.el."
+ (when svn-status-temp-file-to-remove
+ (when (file-exists-p svn-status-temp-file-to-remove)
+ (delete-file svn-status-temp-file-to-remove))
+ (when (file-exists-p svn-status-temp-arg-file)
+ (delete-file svn-status-temp-arg-file))
+ (setq svn-status-temp-file-to-remove nil)))
+
+(defun svn-status-remove-control-M ()
+ "Remove ^M at end of line in the whole buffer."
+ (interactive)
+ (let ((buffer-read-only nil))
+ (save-match-data
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward "\r$" (point-max) t)
+ (replace-match "" nil nil))))))
+
+(condition-case nil
+ ;;(easy-menu-add-item nil '("tools") ["SVN Status" svn-status t] "PCL-CVS")
+ (easy-menu-add-item nil '("tools") ["SVN Status" svn-status t])
+ (error (message "psvn: could not install menu")))
+
+(defvar svn-status-mode-map () "Keymap used in `svn-status-mode' buffers.")
+(defvar svn-status-mode-property-map ()
+ "Subkeymap used in `svn-status-mode' for property commands.")
+
+(when (not svn-status-mode-map)
+ (setq svn-status-mode-map (make-sparse-keymap))
+ (suppress-keymap svn-status-mode-map)
+ ;; Don't use (kbd "<return>"); it's unreachable with GNU Emacs 21.3 on a TTY.
+ (define-key svn-status-mode-map (kbd "RET") 'svn-status-find-file-or-examine-directory)
+ (define-key svn-status-mode-map (kbd "^") 'svn-status-examine-parent)
+ (define-key svn-status-mode-map (kbd "s") 'svn-status-show-process-buffer)
+ (define-key svn-status-mode-map (kbd "f") 'svn-status-find-files)
+ (define-key svn-status-mode-map (kbd "o") 'svn-status-find-file-other-window)
+ (define-key svn-status-mode-map (kbd "v") 'svn-status-view-file-other-window)
+ (define-key svn-status-mode-map (kbd "e") 'svn-status-toggle-edit-cmd-flag)
+ (define-key svn-status-mode-map (kbd "g") 'svn-status-update)
+ (define-key svn-status-mode-map (kbd "q") 'svn-status-bury-buffer)
+ (define-key svn-status-mode-map (kbd "h") 'svn-status-use-history)
+ (define-key svn-status-mode-map (kbd "m") 'svn-status-set-user-mark)
+ (define-key svn-status-mode-map (kbd "u") 'svn-status-unset-user-mark)
+ ;; This matches a binding of `dired-unmark-all-files' in `dired-mode-map'
+ ;; of both GNU Emacs and XEmacs. It seems unreachable with XEmacs on
+ ;; TTY, but if that's a problem then its Dired needs fixing too.
+ ;; Or you could just use "*!".
+ (define-key svn-status-mode-map "\M-\C-?" 'svn-status-unset-all-usermarks)
+ ;; The key that normally deletes characters backwards should here
+ ;; instead unmark files backwards. In GNU Emacs, that would be (kbd
+ ;; "DEL") aka [?\177], but XEmacs treats those as [(delete)] and
+ ;; would bind a key that normally deletes forwards. [(backspace)]
+ ;; is unreachable with GNU Emacs on a tty. Try to recognize the
+ ;; dialect and act accordingly.
+ ;;
+ ;; XEmacs has a `delete-forward-p' function that checks the
+ ;; `delete-key-deletes-forward' option. We don't use those, for two
+ ;; reasons: psvn.el may be loaded before user customizations, and
+ ;; XEmacs allows simultaneous connections to multiple devices with
+ ;; different keyboards.
+ (define-key svn-status-mode-map
+ (if (member (kbd "DEL") '([(delete)] [delete]))
+ [(backspace)] ; XEmacs
+ (kbd "DEL")) ; GNU Emacs
+ 'svn-status-unset-user-mark-backwards)
+ (define-key svn-status-mode-map (kbd "$") 'svn-status-toggle-elide)
+ (define-key svn-status-mode-map (kbd ".") 'svn-status-goto-root-or-return)
+ (define-key svn-status-mode-map (kbd "I") 'svn-status-parse-info)
+ (define-key svn-status-mode-map (kbd "?") 'svn-status-toggle-hide-unknown)
+ (define-key svn-status-mode-map (kbd "_") 'svn-status-toggle-hide-unmodified)
+ (define-key svn-status-mode-map (kbd "a") 'svn-status-add-file)
+ (define-key svn-status-mode-map (kbd "A") 'svn-status-add-file-recursively)
+ (define-key svn-status-mode-map (kbd "+") 'svn-status-make-directory)
+ (define-key svn-status-mode-map (kbd "R") 'svn-status-mv)
+ (define-key svn-status-mode-map (kbd "D") 'svn-status-rm)
+ (define-key svn-status-mode-map (kbd "c") 'svn-status-commit-file)
+ (define-key svn-status-mode-map (kbd "M-c") 'svn-status-cleanup)
+ (define-key svn-status-mode-map (kbd "U") 'svn-status-update-cmd)
+ (define-key svn-status-mode-map (kbd "r") 'svn-status-revert)
+ (define-key svn-status-mode-map (kbd "l") 'svn-status-show-svn-log)
+ (define-key svn-status-mode-map (kbd "i") 'svn-status-info)
+ (define-key svn-status-mode-map (kbd "b") 'svn-status-blame)
+ (define-key svn-status-mode-map (kbd "=") 'svn-status-show-svn-diff)
+ ;; [(control ?=)] is unreachable on TTY, but you can use "*u" instead.
+ ;; (Is the "u" mnemonic for something?)
+ (define-key svn-status-mode-map (kbd "C-=") 'svn-status-show-svn-diff-for-marked-files)
+ (define-key svn-status-mode-map (kbd "~") 'svn-status-get-specific-revision)
+ (define-key svn-status-mode-map (kbd "E") 'svn-status-ediff-with-revision)
+ (define-key svn-status-mode-map (kbd "C-n") 'svn-status-next-line)
+ (define-key svn-status-mode-map (kbd "C-p") 'svn-status-previous-line)
+ (define-key svn-status-mode-map (kbd "<down>") 'svn-status-next-line)
+ (define-key svn-status-mode-map (kbd "<up>") 'svn-status-previous-line)
+ (setq svn-status-mode-mark-map (make-sparse-keymap))
+ (define-key svn-status-mode-map (kbd "*") svn-status-mode-mark-map)
+ (define-key svn-status-mode-mark-map (kbd "!") 'svn-status-unset-all-usermarks)
+ (define-key svn-status-mode-mark-map (kbd "?") 'svn-status-mark-unknown)
+ (define-key svn-status-mode-mark-map (kbd "A") 'svn-status-mark-added)
+ (define-key svn-status-mode-mark-map (kbd "M") 'svn-status-mark-modified)
+ (define-key svn-status-mode-mark-map (kbd "V") 'svn-status-resolved)
+ (define-key svn-status-mode-mark-map (kbd "u") 'svn-status-show-svn-diff-for-marked-files))
+(when (not svn-status-mode-property-map)
+ (setq svn-status-mode-property-map (make-sparse-keymap))
+ (define-key svn-status-mode-property-map (kbd "l") 'svn-status-property-list)
+ (define-key svn-status-mode-property-map (kbd "s") 'svn-status-property-set)
+ (define-key svn-status-mode-property-map (kbd "d") 'svn-status-property-delete)
+ (define-key svn-status-mode-property-map (kbd "e") 'svn-status-property-edit-one-entry)
+ (define-key svn-status-mode-property-map (kbd "i") 'svn-status-property-ignore-file)
+ (define-key svn-status-mode-property-map (kbd "I") 'svn-status-property-ignore-file-extension)
+ ;; XEmacs 21.4.15 on TTY (vt420) converts `C-i' to `TAB',
+ ;; which [(control ?i)] won't match. Handle it separately.
+ ;; On GNU Emacs, the following two forms bind the same key,
+ ;; reducing clutter in `where-is'.
+ (define-key svn-status-mode-property-map [(control ?i)] 'svn-status-property-edit-svn-ignore)
+ (define-key svn-status-mode-property-map (kbd "TAB") 'svn-status-property-edit-svn-ignore)
+ (define-key svn-status-mode-property-map (kbd "k") 'svn-status-property-set-keyword-list)
+ (define-key svn-status-mode-property-map (kbd "y") 'svn-status-property-set-eol-style)
+ (define-key svn-status-mode-property-map (kbd "p") 'svn-status-property-parse)
+ ;; TODO: Why is `svn-status-select-line' in `svn-status-mode-property-map'?
+ (define-key svn-status-mode-property-map (kbd "RET") 'svn-status-select-line)
+ (define-key svn-status-mode-map (kbd "P") svn-status-mode-property-map))
+
+
+(easy-menu-define svn-status-mode-menu svn-status-mode-map
+ "'svn-status-mode' menu"
+ '("SVN"
+ ["svn status" svn-status-update t]
+ ["svn update" svn-status-update-cmd t]
+ ["svn commit" svn-status-commit-file t]
+ ["svn log" svn-status-show-svn-log t]
+ ["svn info" svn-status-info t]
+ ["svn blame" svn-status-blame t]
+ ("Diff"
+ ["svn diff current file" svn-status-show-svn-diff t]
+ ["svn diff marked files" svn-status-show-svn-diff-for-marked-files t]
+ ["svn ediff current file" svn-status-ediff-with-revision t]
+ )
+ ["svn cat ..." svn-status-get-specific-revision t]
+ ["svn add" svn-status-add-file t]
+ ["svn mkdir..." svn-status-make-directory t]
+ ["svn mv..." svn-status-mv t]
+ ["svn rm..." svn-status-rm t]
+ ["Up Directory" svn-status-examine-parent t]
+ ["Elide Directory" svn-status-toggle-elide t]
+ ["svn revert" svn-status-revert t]
+ ["svn resolved" svn-status-resolved t]
+ ["svn cleanup" svn-status-cleanup t]
+ ["Show Process Buffer" svn-status-show-process-buffer t]
+ ("Property"
+ ["svn proplist" svn-status-property-list t]
+ ["Set Multiple Properties..." svn-status-property-set t]
+ ["Edit One Property..." svn-status-property-edit-one-entry t]
+ ["svn propdel..." svn-status-property-delete t]
+ "---"
+ ["svn:ignore File..." svn-status-property-ignore-file t]
+ ["svn:ignore File Extension..." svn-status-property-ignore-file-extension t]
+ ["Edit svn:ignore Property" svn-status-property-edit-svn-ignore t]
+ "---"
+ ["Set svn:keywords List" svn-status-property-set-keyword-list t]
+ ["Set svn:eol-style" svn-status-property-set-eol-style t]
+ )
+ "---"
+ ["Edit Next SVN Cmd Line" svn-status-toggle-edit-cmd-flag t]
+ ["Work Directory History..." svn-status-use-history t]
+ ["Mark" svn-status-set-user-mark t]
+ ["Unmark" svn-status-unset-user-mark t]
+ ("Mark / Unmark"
+ ["Unmark all" svn-status-unset-all-usermarks t]
+ ["Mark/Unmark unknown" svn-status-mark-unknown t]
+ ["Mark/Unmark added" svn-status-mark-added t]
+ ["Mark/Unmark modified" svn-status-mark-modified t]
+ )
+ ["Hide Unknown" svn-status-toggle-hide-unknown
+ :style toggle :selected svn-status-hide-unknown]
+ ["Hide Unmodified" svn-status-toggle-hide-unmodified
+ :style toggle :selected svn-status-hide-unmodified]
+ ))
+
+(defun svn-status-mode ()
+ "Major mode used by psvn.el to process the output of \"svn status\".
+
+psvn.el is an interface for the revision control tool subversion
+\(see http://subversion.tigris.org).
+psvn.el provides a similar interface for subversion as pcl-cvs does for cvs.
+At the moment the following commands are implemented:
+ M-x svn-status: run 'svn -status -v'
+ and show the result in the *svn-status* buffer, this buffer uses the
+ svn-status mode. In this mode the following keys are defined:
+\\{svn-status-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+
+ (use-local-map svn-status-mode-map)
+ (easy-menu-add svn-status-mode-menu)
+
+ (setq major-mode 'svn-status-mode)
+ (setq mode-name "svn-status")
+ (setq mode-line-process 'svn-status-mode-line-process)
+ (let ((view-read-only nil))
+ (toggle-read-only 1)))
+
+(defun svn-status-update-mode-line ()
+ (setq svn-status-mode-line-process
+ (concat svn-status-mode-line-process-edit-flag svn-status-mode-line-process-status))
+ (force-mode-line-update))
+
+(defun svn-status-bury-buffer (arg)
+ "Bury the *svn-status* buffer.
+When called with a prefix argument, switch back to the window configuration that was
+in use before `svn-status' was called."
+ (interactive "P")
+ (cond (arg
+ (when svn-status-initial-window-configuration
+ (set-window-configuration svn-status-initial-window-configuration)))
+ (t
+ (let ((bl '("*svn-log-edit*" "*svn-property-edit*" "*svn-process*")))
+ (while bl
+ (when (get-buffer (car bl))
+ (bury-buffer (car bl)))
+ (setq bl (cdr bl)))
+ (when (string= (buffer-name) "*svn-status*")
+ (bury-buffer))))))
+
+(defun svn-status-find-files ()
+ "Open selected file(s) for editing.
+See `svn-status-marked-files' for what counts as selected."
+ (interactive)
+ (let ((fnames (mapcar 'svn-status-line-info->full-path (svn-status-marked-files))))
+ (mapc 'find-file fnames)))
+
+
+(defun svn-status-find-file-other-window ()
+ "Open the file in the other window for editing."
+ (interactive)
+ (find-file-other-window (svn-status-line-info->filename
+ (svn-status-get-line-information))))
+
+(defun svn-status-view-file-other-window ()
+ "Open the file in the other window for viewing."
+ (interactive)
+ (view-file-other-window (svn-status-line-info->filename
+ (svn-status-get-line-information))))
+
+(defun svn-status-find-file-or-examine-directory ()
+ "If point is on a directory, run `svn-status' on that directory.
+Otherwise run `find-file'."
+ (interactive)
+ (let ((line-info (svn-status-get-line-information)))
+ (if (svn-status-line-info->directory-p line-info)
+ (svn-status (svn-status-line-info->full-path line-info))
+ (find-file (svn-status-line-info->filename line-info)))))
+
+(defun svn-status-examine-parent ()
+ "Run `svn-status' on the parent of the current directory."
+ (interactive)
+ (svn-status (expand-file-name "../")))
+
+(defun svn-status-line-info->ui-status (line-info) (nth 0 line-info))
+
+(defun svn-status-line-info->has-usermark (line-info) (nth 0 (nth 0 line-info)))
+(defun svn-status-line-info->user-elide (line-info) (nth 1 (nth 0 line-info)))
+
+(defun svn-status-line-info->filemark (line-info) (nth 1 line-info))
+(defun svn-status-line-info->propmark (line-info) (nth 2 line-info))
+(defun svn-status-line-info->filename (line-info) (nth 3 line-info))
+(defun svn-status-line-info->filename-nondirectory (line-info)
+ (file-name-nondirectory (svn-status-line-info->filename line-info)))
+(defun svn-status-line-info->localrev (line-info)
+ (if (>= (nth 4 line-info) 0)
+ (nth 4 line-info)
+ nil))
+(defun svn-status-line-info->lastchangerev (line-info)
+ "Return the last revision in which LINE-INFO was modified."
+ (if (>= (nth 5 line-info) 0)
+ (nth 5 line-info)
+ nil))
+(defun svn-status-line-info->author (line-info) (nth 6 line-info))
+(defun svn-status-line-info->modified-external (line-info) (nth 7 line-info))
+
+(defun svn-status-line-info->is-visiblep (line-info)
+ (not (or (svn-status-line-info->hide-because-unknown line-info)
+ (svn-status-line-info->hide-because-unmodified line-info)
+ (svn-status-line-info->hide-because-user-elide line-info))))
+
+(defun svn-status-line-info->hide-because-unknown (line-info)
+ (and svn-status-hide-unknown
+ (eq (svn-status-line-info->filemark line-info) ??)))
+
+(defun svn-status-line-info->hide-because-unmodified (line-info)
+ ;;(message " %S %S %S %S - %s" svn-status-hide-unmodified (svn-status-line-info->propmark line-info) ?_
+ ;; (svn-status-line-info->filemark line-info) (svn-status-line-info->filename line-info))
+ (and svn-status-hide-unmodified
+ (and (or (eq (svn-status-line-info->filemark line-info) ?_)
+ (eq (svn-status-line-info->filemark line-info) ? ))
+ (or (eq (svn-status-line-info->propmark line-info) ?_)
+ (eq (svn-status-line-info->propmark line-info) ? )
+ (eq (svn-status-line-info->propmark line-info) nil)))))
+
+(defun svn-status-line-info->hide-because-user-elide (line-info)
+ (eq (svn-status-line-info->user-elide line-info) t))
+
+(defun svn-status-line-info->show-user-elide-continuation (line-info)
+ (eq (svn-status-line-info->user-elide line-info) 'directory))
+
+;; modify the line-info
+(defun svn-status-line-info->set-filemark (line-info value)
+ (setcar (nthcdr 1 line-info) value))
+
+(defun svn-status-toggle-elide ()
+ (interactive)
+ (let ((st-info svn-status-info)
+ (fname)
+ (test (svn-status-line-info->filename (svn-status-get-line-information)))
+ (len-test)
+ (len-fname)
+ (new-elide-mark t)
+ (elide-mark))
+ (when (string= test ".")
+ (setq test ""))
+ (setq len-test (length test))
+ (while st-info
+ (setq fname (svn-status-line-info->filename (car st-info)))
+ (setq len-fname (length fname))
+ (when (and (>= len-fname len-test)
+ (string= (substring fname 0 len-test) test))
+ ;;(message "elide: %s %s" fname (svn-status-line-info->user-elide (car st-info)))
+ (setq elide-mark new-elide-mark)
+ (when (or (string= fname ".")
+ (and (= len-fname len-test) (svn-status-line-info->directory-p (car st-info))))
+ (message "Elide directory %s and all its files." fname)
+ (setq new-elide-mark (not (svn-status-line-info->user-elide (car st-info))))
+ (setq elide-mark (if new-elide-mark 'directory nil)))
+ (setcar (nthcdr 1 (svn-status-line-info->ui-status (car st-info))) elide-mark))
+ (setq st-info (cdr st-info))))
+ (svn-status-update-buffer))
+
+
+(defun svn-status-line-info->directory-p (line-info)
+ "Return t if LINE-INFO refers to a directory, nil otherwise.
+Symbolic links to directories count as directories (see `file-directory-p')."
+ (file-directory-p (svn-status-line-info->filename line-info)))
+
+(defun svn-status-line-info->full-path (line-info)
+ "Return the full path of the file represented by LINE-INFO."
+ (expand-file-name
+ (svn-status-line-info->filename line-info)))
+
+;;Not convinced that this is the fastest way, but...
+(defun svn-status-count-/ (string)
+ "Return number of \"/\"'s in STRING."
+ (let ((n 0)
+ (last 0))
+ (while (setq last (string-match "/" string (1+ last)))
+ (setq n (1+ n)))
+ n))
+
+(defun svn-insert-line-in-status-buffer (line-info)
+ "Format LINE-INFO and insert the result in the current buffer."
+ (let ((usermark (if (svn-status-line-info->has-usermark line-info) "*" " "))
+ (external (if (svn-status-line-info->modified-external line-info)
+ (svn-add-face (if svn-status-short-mod-flag-p
+ "** "
+ " (modified external)")
+ 'svn-status-modified-external-face)
+ (if svn-status-short-mod-flag-p " " "")))
+ ;; To add indentation based on the
+ ;; directory that the file is in, we just insert 2*(number of "/" in
+ ;; filename) spaces, which is rather hacky (but works)!
+ (filename (svn-status-choose-face-to-add
+ (svn-status-line-info->directory-p line-info)
+ (concat (make-string
+ (* 2 (svn-status-count-/
+ (svn-status-line-info->filename line-info)))
+ 32)
+ (if svn-status-hide-unmodified
+ (svn-status-line-info->filename line-info)
+ (svn-status-line-info->filename-nondirectory line-info)))
+ 'svn-status-directory-face
+ 'svn-status-filename-face))
+ (elide-hint (if (svn-status-line-info->show-user-elide-continuation line-info) " ..." "")))
+ (insert (svn-status-maybe-add-face
+ (svn-status-line-info->has-usermark line-info)
+ (concat usermark
+ (format svn-status-line-format
+ (svn-status-line-info->filemark line-info)
+ (or (svn-status-line-info->propmark line-info) ? )
+ (or (svn-status-line-info->localrev line-info) "")
+ (or (svn-status-line-info->lastchangerev line-info) "")
+ (svn-status-line-info->author line-info)))
+ 'svn-status-marked-face)
+ (if svn-status-short-mod-flag-p external filename)
+ (if svn-status-short-mod-flag-p filename external)
+ elide-hint
+ "\n")))
+
+(defun svn-status-update-buffer ()
+ (interactive)
+ ;(message (format "buffer-name: %s" (buffer-name)))
+ (unless (string= (buffer-name) "*svn-status*")
+ (delete-other-windows)
+ (split-window-vertically)
+ (switch-to-buffer "*svn-status*"))
+ (svn-status-mode)
+ (let ((st-info svn-status-info)
+ (buffer-read-only nil)
+ (start-pos)
+ (overlay)
+ (unmodified-count 0)
+ (unknown-count 0)
+ (marked-count 0)
+ (fname (svn-status-line-info->filename (svn-status-get-line-information)))
+ (fname-pos (point))
+ (column (current-column)))
+ (delete-region (point-min) (point-max))
+ (insert "\n")
+ ;; Insert all files and directories
+ (while st-info
+ (setq start-pos (point))
+ (cond ((svn-status-line-info->has-usermark (car st-info))
+ ;; Show a marked file always
+ (svn-insert-line-in-status-buffer (car st-info)))
+ ((svn-status-line-info->hide-because-user-elide (car st-info))
+ );(message "user wanted to hide %s" (svn-status-line-info->filename (car st-info))))
+ ((svn-status-line-info->hide-because-unknown (car st-info))
+ (setq unknown-count (+ unknown-count 1)))
+ ((svn-status-line-info->hide-because-unmodified (car st-info))
+ (setq unmodified-count (+ unmodified-count 1)))
+ (t
+ (svn-insert-line-in-status-buffer (car st-info))))
+ (when (svn-status-line-info->has-usermark (car st-info))
+ (setq marked-count (+ marked-count 1)))
+ (setq overlay (make-overlay start-pos (point)))
+ (overlay-put overlay 'svn-info (car st-info))
+ (setq st-info (cdr st-info)))
+ ;; Insert status information at the buffer beginning
+ (goto-char (point-min))
+ (insert (format "svn status for directory %s%s\n"
+ default-directory
+ (if svn-status-head-revision (format " (status against revision: %s)"
+ svn-status-head-revision)
+ "")))
+ (when svn-status-base-info
+ (insert (concat "Repository: " (svn-status-base-info->url) "\n")))
+ (when svn-status-hide-unknown
+ (insert
+ (format "%d Unknown files are hidden - press ? to toggle hiding\n"
+ unknown-count)))
+ (when svn-status-hide-unmodified
+ (insert
+ (format "%d Unmodified files are hidden - press _ to toggle hiding\n"
+ unmodified-count)))
+ (insert (format "%d files marked\n" marked-count))
+ (setq svn-start-of-file-list-line-number (+ (count-lines (point-min) (point)) 1))
+ (if fname
+ (progn
+ (goto-char fname-pos)
+ (svn-status-goto-file-name fname)
+ (goto-char (+ column (point-at-bol))))
+ (goto-char (+ (next-overlay-change (point-min)) svn-status-default-column)))))
+
+(defun svn-status-parse-info (arg)
+ "Parse the svn info output for the base directory.
+Show the repository url after this call in the *svn-status* buffer.
+When called with the prefix argument 0, reset the information to nil.
+This hides the repository information again."
+ (interactive "P")
+ (if (eq arg 0)
+ (setq svn-status-base-info nil)
+ (svn-run-svn nil t 'parse-info "info" ".")
+ (svn-status-parse-info-result))
+ (svn-status-update-buffer))
+
+(defun svn-status-parse-info-result ()
+ (let ((url))
+ (save-excursion
+ (set-buffer "*svn-process*")
+ (goto-char (point-min))
+ (search-forward "Url: ")
+ (setq url (buffer-substring-no-properties (point) (point-at-eol))))
+ (setq svn-status-base-info `((url ,url)))))
+
+(defun svn-status-base-info->url ()
+ (if svn-status-base-info
+ (cadr (assoc 'url svn-status-base-info))
+ ""))
+
+(defun svn-status-toggle-edit-cmd-flag (&optional reset)
+ (interactive)
+ (cond ((or reset (eq svn-status-edit-svn-command 'sticky))
+ (setq svn-status-edit-svn-command nil))
+ ((eq svn-status-edit-svn-command nil)
+ (setq svn-status-edit-svn-command t))
+ ((eq svn-status-edit-svn-command t)
+ (setq svn-status-edit-svn-command 'sticky)))
+ (cond ((eq svn-status-edit-svn-command t)
+ (setq svn-status-mode-line-process-edit-flag " EditCmd"))
+ ((eq svn-status-edit-svn-command 'sticky)
+ (setq svn-status-mode-line-process-edit-flag " EditCmd#"))
+ (t
+ (setq svn-status-mode-line-process-edit-flag "")))
+ (svn-status-update-mode-line))
+
+(defun svn-status-goto-root-or-return ()
+ "Bounce point between the root (\".\") and the current line."
+ (interactive)
+ (if (string= (svn-status-line-info->filename (svn-status-get-line-information)) ".")
+ (when svn-status-root-return-info
+ (svn-status-goto-file-name
+ (svn-status-line-info->filename svn-status-root-return-info)))
+ (setq svn-status-root-return-info (svn-status-get-line-information))
+ (svn-status-goto-file-name ".")))
+
+(defun svn-status-next-line (nr-of-lines)
+ (interactive "p")
+ (next-line nr-of-lines)
+ (when (svn-status-get-line-information)
+ (goto-char (+ (point-at-bol) svn-status-default-column))))
+
+(defun svn-status-previous-line (nr-of-lines)
+ (interactive "p")
+ (previous-line nr-of-lines)
+ (when (svn-status-get-line-information)
+ (goto-char (+ (point-at-bol) svn-status-default-column))))
+
+(defun svn-status-update (&optional arg)
+ "Run 'svn status -v'.
+When called with a prefix argument run 'svn status -vu'."
+ (interactive "P")
+ (unless (interactive-p)
+ (save-excursion
+ (set-buffer "*svn-process*")
+ (setq svn-status-update-previous-process-output (buffer-substring (point-min) (point-max)))))
+ (svn-status default-directory arg))
+
+(defun svn-status-get-line-information ()
+ "Find out about the file under point.
+The result may be parsed with the various `svn-status-line-info->...' functions."
+ (let ((overlay (car (overlays-at (point)))))
+ (when overlay
+ (overlay-get overlay 'svn-info))))
+
+(defun svn-status-get-file-list (use-marked-files)
+ "Get either the marked files or the files, where the cursor is on."
+ (if use-marked-files
+ (svn-status-marked-files)
+ (list (svn-status-get-line-information))))
+
+(defun svn-status-get-file-list-names (use-marked-files)
+ (mapcar 'svn-status-line-info->filename (svn-status-get-file-list use-marked-files)))
+
+(defun svn-status-select-line ()
+ (interactive)
+ (let ((info (svn-status-get-line-information)))
+ (if info
+ (message "%S %S %S" info (svn-status-line-info->hide-because-unknown info)
+ (svn-status-line-info->hide-because-unmodified info))
+ (message "No file on this line"))))
+
+(defun svn-status-directory-containing-point (allow-self)
+ "Find the (full path of) directory containing the file under point.
+
+If ALLOW-SELF and the file is a directory, return that directory,
+otherwise return the directory containing the file under point."
+ ;;the first `or' below is because s-s-g-l-i returns `nil' if
+ ;;point was outside the file list, but we need
+ ;;s-s-l-i->f to return a string to add to `default-directory'.
+ (let ((line-info (or (svn-status-get-line-information)
+ '(nil nil nil ""))))
+ (file-name-as-directory
+ (expand-file-name
+ (if (and allow-self (svn-status-line-info->directory-p line-info))
+ (svn-status-line-info->filename line-info)
+ ;;The next `or' is because (file-name-directory "file") returns nil
+ (or (file-name-directory (svn-status-line-info->filename line-info))
+ "."))))))
+
+(defun svn-status-set-user-mark (arg)
+ "Set a user mark on the current file or directory.
+If the cursor is on a file this file is marked and the cursor advances to the next line.
+If the cursor is on a directory all files in this directory are marked.
+
+If this function is called with a prefix argument, only the current line is
+marked, even if it is a directory."
+ (interactive "P")
+ (let ((info (svn-status-get-line-information)))
+ (if info
+ (progn
+ (svn-status-apply-usermark t arg)
+ (svn-status-next-line 1))
+ (message "No file on this line - cannot set a mark"))))
+
+(defun svn-status-unset-user-mark (arg)
+ "Remove a user mark on the current file or directory.
+If the cursor is on a file, this file is unmarked and the cursor advances to the next line.
+If the cursor is on a directory, all files in this directory are unmarked.
+
+If this function is called with a prefix argument, only the current line is
+unmarked, even if is a directory."
+ (interactive "P")
+ (let ((info (svn-status-get-line-information)))
+ (if info
+ (progn
+ (svn-status-apply-usermark nil arg)
+ (svn-status-next-line 1))
+ (message "No file on this line - cannot unset a mark"))))
+
+(defun svn-status-unset-user-mark-backwards ()
+ "Remove a user mark from the previous file.
+Then move to that line."
+ ;; This is consistent with `dired-unmark-backward' and
+ ;; `cvs-mode-unmark-up'.
+ (interactive)
+ (let ((info (save-excursion
+ (svn-status-next-line -1)
+ (svn-status-get-line-information))))
+ (if info
+ (progn
+ (svn-status-next-line -1)
+ (svn-status-apply-usermark nil t))
+ (message "No file on previous line - cannot unset a mark"))))
+
+(defun svn-status-apply-usermark (set-mark only-this-line)
+ "Do the work for the various marking/unmarking functions."
+ (let* ((st-info svn-status-info)
+ (line-info (svn-status-get-line-information))
+ (file-name (svn-status-line-info->filename line-info))
+ (sub-file-regexp (concat "^" (regexp-quote
+ (file-name-as-directory file-name))))
+ (newcursorpos-fname)
+ (i-fname)
+ (current-line svn-start-of-file-list-line-number))
+ (while st-info
+ (when (svn-status-line-info->is-visiblep (car st-info))
+ (setq current-line (1+ current-line)))
+ (setq i-fname (svn-status-line-info->filename (car st-info)))
+ (when (or (string= file-name i-fname)
+ (string-match sub-file-regexp i-fname))
+ (when (svn-status-line-info->is-visiblep (car st-info))
+ (when (or (not only-this-line) (string= file-name i-fname))
+ (setq newcursorpos-fname i-fname)
+ (if set-mark
+ (message "marking: %s" i-fname)
+ (message "unmarking: %s" i-fname))
+ ;;(message "ui-status: %S" (svn-status-line-info->ui-status (car st-info)))
+ (setcar (svn-status-line-info->ui-status (car st-info)) set-mark)
+ (save-excursion
+ (let ((buffer-read-only nil))
+ (goto-line current-line)
+ (delete-region (point-at-bol) (point-at-eol))
+ (svn-insert-line-in-status-buffer (car st-info))
+ (delete-char 1))))))
+ (setq st-info (cdr st-info)))
+ ;;(svn-status-update-buffer)
+ (svn-status-goto-file-name newcursorpos-fname)))
+
+(defun svn-status-apply-usermark-checked (check-function set-mark)
+ "Mark or unmark files, whether a given function returns t.
+The function is called with the line information. Therefore the svnstatus-line-info->* functions can be
+used in the check."
+ (let ((st-info svn-status-info))
+ (while st-info
+ (when (apply check-function (list (car st-info)))
+ (if set-mark
+ (when (not (svn-status-line-info->has-usermark (car st-info)))
+ (message "marking: %s" (svn-status-line-info->filename (car st-info))))
+ (when (svn-status-line-info->has-usermark (car st-info))
+ (message "unmarking: %s" (svn-status-line-info->filename (car st-info)))))
+ (setcar (svn-status-line-info->ui-status (car st-info)) set-mark))
+ (setq st-info (cdr st-info)))
+ (svn-status-update-buffer)))
+
+(defun svn-status-mark-unknown (arg)
+ "Mark all unknown files.
+These are the files marked with '?' in the *svn-status* buffer.
+If the function is called with a prefix arg, unmark all these files."
+ (interactive "P")
+ (svn-status-apply-usermark-checked '(lambda (info) (eq (svn-status-line-info->filemark info) ??)) (not arg)))
+
+(defun svn-status-mark-added (arg)
+ "Mark all added files.
+These are the files marked with 'A' in the *svn-status* buffer.
+If the function is called with a prefix arg, unmark all these files."
+ (interactive "P")
+ (svn-status-apply-usermark-checked '(lambda (info) (eq (svn-status-line-info->filemark info) ?A)) (not arg)))
+
+(defun svn-status-mark-modified (arg)
+ "Mark all modified files.
+These are the files marked with 'M' in the *svn-status* buffer.
+If the function is called with a prefix arg, unmark all these files."
+ (interactive "P")
+ (svn-status-apply-usermark-checked '(lambda (info) (eq (svn-status-line-info->filemark info) ?M)) (not arg)))
+
+(defun svn-status-unset-all-usermarks ()
+ (interactive)
+ (svn-status-apply-usermark-checked '(lambda (info) t) nil))
+
+(defun svn-status-toggle-hide-unknown ()
+ (interactive)
+ (setq svn-status-hide-unknown (not svn-status-hide-unknown))
+ (svn-status-update-buffer))
+
+(defun svn-status-toggle-hide-unmodified ()
+ (interactive)
+ (setq svn-status-hide-unmodified (not svn-status-hide-unmodified))
+ (svn-status-update-buffer))
+
+(defun svn-status-goto-file-name (name)
+ ;; (message "svn-status-goto-file-name: %s %d" name (point))
+ (let ((start-pos (point)))
+ (goto-char (point-min))
+ (while (< (point) (point-max))
+ (goto-char (next-overlay-change (point)))
+ (when (string= name (svn-status-line-info->filename
+ (svn-status-get-line-information)))
+ (setq start-pos (+ (point) svn-status-default-column))))
+ (goto-char start-pos)))
+
+(defun svn-status-find-info-for-file-name (name)
+ (let* ((st-info svn-status-info)
+ (info))
+ (while st-info
+ (when (string= name (svn-status-line-info->filename (car st-info)))
+ (setq info (car st-info))
+ (setq st-info nil)) ; terminate loop
+ (setq st-info (cdr st-info)))
+ info))
+
+(defun svn-status-marked-files ()
+ "Return all files marked by `svn-status-set-user-mark',
+or (if no files were marked) the file under point."
+ (let* ((st-info svn-status-info)
+ (file-list))
+ (while st-info
+ (when (svn-status-line-info->has-usermark (car st-info))
+ (setq file-list (append file-list (list (car st-info)))))
+ (setq st-info (cdr st-info)))
+ (or file-list
+ (if (svn-status-get-line-information)
+ (list (svn-status-get-line-information))
+ nil))))
+
+(defun svn-status-marked-file-names ()
+ (mapcar 'svn-status-line-info->filename (svn-status-marked-files)))
+
+(defun svn-status-ui-information-hash-table ()
+ (let ((st-info svn-status-info)
+ (svn-status-ui-information (make-hash-table :test 'equal)))
+ (while st-info
+ (puthash (svn-status-line-info->filename (car st-info))
+ (svn-status-line-info->ui-status (car st-info))
+ svn-status-ui-information)
+ (setq st-info (cdr st-info)))
+ svn-status-ui-information))
+
+
+(defun svn-status-create-arg-file (file-name prefix file-info-list postfix)
+ (with-temp-file file-name
+ (insert prefix)
+ (let ((st-info file-info-list))
+ (while st-info
+ (insert (svn-status-line-info->filename (car st-info)))
+ (insert "\n")
+ (setq st-info (cdr st-info)))
+
+ (insert postfix))))
+
+(defun svn-status-show-process-buffer-internal (&optional scroll-to-top)
+ (when (eq (current-buffer) "*svn-status*")
+ (delete-other-windows))
+ (pop-to-buffer "*svn-process*")
+ (when svn-status-wash-control-M-in-process-buffers
+ (svn-status-remove-control-M))
+ (when scroll-to-top
+ (goto-char (point-min)))
+ (other-window 1))
+
+(defun svn-status-show-svn-log (arg)
+ "Run `svn log' on selected files.
+When called with a prefix argument add the following command switches:
+ no prefix: use whatever is in the string `svn-status-default-log-arguments'
+ prefix argument of -1: use no arguments
+ prefix argument of 0: use the -q switch (quiet)
+ other prefix arguments: use the -v switch (verbose)
+
+See `svn-status-marked-files' for what counts as selected."
+ (interactive "P")
+ (let ((switch (cond ((eq arg 0) "-q")
+ ((eq arg -1) "")
+ (arg "-v")
+ (t svn-status-default-log-arguments))))
+ ;;(message "show log info for: %S" (svn-status-marked-files))
+ (svn-status-create-arg-file svn-status-temp-arg-file "" (svn-status-marked-files) "")
+ (if (> (length switch) 0)
+ (svn-run-svn t t 'log "log" "--targets" svn-status-temp-arg-file switch)
+ (svn-run-svn t t 'log "log" "--targets" svn-status-temp-arg-file))
+ (save-excursion
+ (set-buffer "*svn-process*")
+ (svn-log-view-mode))))
+
+(defun svn-status-info ()
+ "Run `svn info' on all selected files.
+See `svn-status-marked-files' for what counts as selected."
+ (interactive)
+ (svn-status-create-arg-file svn-status-temp-arg-file "" (svn-status-marked-files) "")
+ (svn-run-svn t t 'info "info" "--targets" svn-status-temp-arg-file))
+
+;; Todo: add possiblity to specify the revision
+(defun svn-status-blame ()
+ "Run `svn blame' on the current file."
+ (interactive)
+ ;;(svn-run-svn t t 'blame "blame" "-r" "BASE" (svn-status-line-info->filename (svn-status-get-line-information))))
+ (svn-run-svn t t 'blame "blame" (svn-status-line-info->filename (svn-status-get-line-information))))
+
+(defun svn-status-show-svn-diff (arg)
+ "Run `svn diff' on the current file.
+If there is a newer revision in the repository, the diff is done against HEAD, otherwise
+compare the working copy with BASE.
+If ARG then prompt for revision to diff against."
+ (interactive "P")
+ (svn-status-show-svn-diff-internal arg nil))
+
+(defun svn-status-show-svn-diff-for-marked-files (arg)
+ "Run `svn diff' on all selected files.
+See `svn-status-marked-files' for what counts as selected.
+If ARG then prompt for revision to diff against, else compare working copy with BASE."
+ (interactive "P")
+ (svn-status-show-svn-diff-internal arg t))
+
+(defun svn-status-show-svn-diff-internal (arg &optional use-all-marked-files)
+ (let* ((fl (if use-all-marked-files
+ (svn-status-marked-files)
+ (list (svn-status-get-line-information))))
+ (clear-buf t)
+ (revision (if arg
+ (svn-status-read-revision-string "Diff with files for version: " "PREV")
+ (if use-all-marked-files
+ "BASE"
+ (if (svn-status-line-info->modified-external (car fl)) "HEAD" "BASE")))))
+ (while fl
+ (svn-run-svn nil clear-buf 'diff "diff" "-r" revision (svn-status-line-info->filename (car fl)))
+ (setq clear-buf nil)
+ (setq fl (cdr fl))))
+ (svn-status-show-process-buffer-internal t)
+ (save-excursion
+ (set-buffer "*svn-process*")
+ (diff-mode)
+ (font-lock-fontify-buffer)))
+
+(defun svn-status-show-process-buffer ()
+ (interactive)
+ (svn-status-show-process-buffer-internal))
+
+(defun svn-status-add-file-recursively (arg)
+ "Run `svn add' on all selected files.
+When a directory is added, add files recursively.
+See `svn-status-marked-files' for what counts as selected.
+When this function is called with a prefix argument, use the actual file instead."
+ (interactive "P")
+ (message "adding: %S" (svn-status-get-file-list-names (not arg)))
+ (svn-status-create-arg-file svn-status-temp-arg-file "" (svn-status-get-file-list (not arg)) "")
+ (svn-run-svn t t 'add "add" "--targets" svn-status-temp-arg-file))
+
+(defun svn-status-add-file (arg)
+ "Run `svn add' on all selected files.
+When a directory is added, don't add the files of the directory
+ (svn add --non-recursive <file-list> is called).
+See `svn-status-marked-files' for what counts as selected.
+When this function is called with a prefix argument, use the actual file instead."
+ (interactive "P")
+ (message "adding: %S" (svn-status-get-file-list-names (not arg)))
+ (svn-status-create-arg-file svn-status-temp-arg-file "" (svn-status-get-file-list (not arg)) "")
+ (svn-run-svn t t 'add "add" "--non-recursive" "--targets" svn-status-temp-arg-file))
+
+(defun svn-status-make-directory (dir)
+ "Run `svn mkdir DIR'."
+ ;; TODO: Allow entering a URI interactively.
+ ;; Currently, `read-file-name' corrupts it.
+ (interactive (list (read-file-name "Make directory: "
+ (svn-status-directory-containing-point t))))
+ (unless (string-match "^[^:/]+://" dir) ; Is it a URI?
+ (setq dir (file-relative-name dir)))
+ (svn-run-svn t t 'mkdir "mkdir" "--" dir))
+
+;;TODO: write a svn-status-cp similar to this---maybe a common
+;;function to do both?
+(defun svn-status-mv ()
+ "Prompt for a destination, and `svn mv' selected files there.
+See `svn-status-marked-files' for what counts as `selected'.
+
+If one file was selected then the destination DEST should be a
+filename to rename the selected file to, or a directory to move the
+file into; if multiple files were selected then DEST should be a
+directory to move the selected files into.
+
+The default DEST is the directory containing point.
+
+BUG: If we've marked some directory containging a file as well as the
+file itself, then we should just mv the directory, but this implementation
+doesn't check for that.
+SOLUTION: for each dir, umark all its contents (but not the dir
+itself) before running mv."
+ (interactive)
+ (let* ((marked-files (svn-status-marked-files))
+ (num-of-files (length marked-files))
+ original
+ dest)
+ (if (= 1 num-of-files)
+ ;; one file to rename, prompt for new name, or directory to move the
+ ;; file into.
+ (setq dest (read-file-name (format "Rename %s to: "
+ (svn-status-line-info->filename (car marked-files)))
+ (svn-status-directory-containing-point t)))
+ ;;multiple files selected, so prompt for existing directory to mv them into.
+ (setq dest (read-directory-name (format "Move %d files to directory: " num-of-files)
+ (svn-status-directory-containing-point t) nil t))
+ (unless (file-directory-p dest)
+ (error "%s is not a directory" dest)))
+ (when (string= dest "")
+ (error "No destination entered; no files moved"))
+ (unless (string-match "^[^:/]+://" dest) ; Is it a URI?
+ (setq dest (file-relative-name dest)))
+;
+ ;;do the move: svn mv only lets us move things once at a time, so
+ ;;we need to run svn mv once for each file (hence second arg to
+ ;;svn-run-svn is nil.)
+
+ ;;TODO: before doing any moving, For every marked directory,
+ ;;ensure none of its contents are also marked, since we dont want
+ ;;to move both file *and* its parent...
+ ;; what about hidden files?? what if user marks a dir+contents, then presses `_' ??
+;; ;one solution:
+;; (dolist (original marked-files)
+;; (when (svn-status-line-info->directory-p original)
+;; ;; run svn-status-goto-file-name to move point to line of file
+;; ;; run svn-status-unset-user-mark to unmark dir+all contents
+;; ;; run svn-status-set-user-mark to remark dir
+;; ;; maybe check for local mods here, and unmark if user does't say --force?
+;; ))
+ (dolist (original marked-files)
+ (let ((original-name (svn-status-line-info->filename original))
+ (original-filemarks (svn-status-line-info->filemark original))
+ (original-propmarks (svn-status-line-info->propmark original)))
+ (cond
+ ((or (eq original-filemarks 77) ;;original has local mods: maybe do `svn mv --force'
+ (eq original-propmarks 77)) ;;original has local prop mods: maybe do `svn mv --force'
+ (if (yes-or-no-p (format "%s has local modifications; use `--force' to really move it? "
+ original-name))
+ (svn-run-svn nil t 'mv "mv" "--force" "--" original-name dest)
+ (message "Not moving %s" original-name)))
+ ((eq original-filemarks 63) ;;original is unversioned: maybe do plain `mv'
+ (if (yes-or-no-p (format "%s is unversioned. Use plain `mv -i %s %s'? "
+ original-name original-name dest))
+ (call-process "mv" nil (get-buffer-create "*svn-process*") nil "-i" original-name dest)
+ (message "Not moving %s" original-name)))
+
+ ((eq original-filemarks 65) ;;original has `A' mark (eg it was `svn add'ed, but not committed)
+ (message "Not moving %s (try committing it first)" original-name))
+
+ ((eq original-filemarks 32) ;;original is unmodified: can use `svn mv'
+ (svn-run-svn nil t 'mv "mv" "--" original-name dest))
+
+ ;;file is conflicted in some way?
+ (t
+ (if (yes-or-no-p (format "The status of %s looks scary. Risk moving it anyway? " original-name))
+ (svn-run-svn nil t 'mv "mv" "--" original-name dest)
+ (message "Not moving %s" original-name))))))
+ (svn-status-update)))
+
+(defun svn-status-revert ()
+ "Run `svn revert' on all selected files.
+See `svn-status-marked-files' for what counts as selected."
+ (interactive)
+ (let* ((marked-files (svn-status-marked-files))
+ (num-of-files (length marked-files)))
+ (when (yes-or-no-p
+ (if (= 1 num-of-files)
+ (format "Revert %s? " (svn-status-line-info->filename (car marked-files)))
+ (format "Revert %d files? " num-of-files)))
+ (message "reverting: %S" (svn-status-marked-file-names))
+ (svn-status-create-arg-file svn-status-temp-arg-file "" (svn-status-marked-files) "")
+ (svn-run-svn t t 'revert "revert" "--targets" svn-status-temp-arg-file))))
+
+(defun svn-status-rm (force)
+ "Run `svn rm' on all selected files.
+See `svn-status-marked-files' for what counts as selected.
+When called with a prefix argument add the command line switch --force."
+ (interactive "P")
+ (let* ((marked-files (svn-status-marked-files))
+ (num-of-files (length marked-files)))
+ (when (yes-or-no-p
+ (if (= 1 num-of-files)
+ (format "%sRemove %s? " (if force "Force " "") (svn-status-line-info->filename (car marked-files)))
+ (format "%sRemove %d files? " (if force "Force " "") num-of-files)))
+ (message "removing: %S" (svn-status-marked-file-names))
+ (svn-status-create-arg-file svn-status-temp-arg-file "" (svn-status-marked-files) "")
+ (if force
+ (svn-run-svn t t 'rm "rm" "--force" "--targets" svn-status-temp-arg-file)
+ (svn-run-svn t t 'rm "rm" "--targets" svn-status-temp-arg-file)))))
+
+(defun svn-status-update-cmd ()
+ (interactive)
+ ;TODO: use file names also
+ (svn-run-svn t t 'update "update"))
+
+(defun svn-status-commit-file ()
+ (interactive)
+ (let* ((marked-files (svn-status-marked-files)))
+ (setq svn-status-files-to-commit marked-files)
+ (svn-log-edit-show-files-to-commit)
+ (svn-status-pop-to-commit-buffer)))
+
+(defun svn-status-pop-to-commit-buffer ()
+ (interactive)
+ (setq svn-status-pre-commit-window-configuration (current-window-configuration))
+ (let* ((use-existing-buffer (get-buffer "*svn-log-edit*"))
+ (commit-buffer (get-buffer-create "*svn-log-edit*"))
+ (dir default-directory))
+ (pop-to-buffer commit-buffer)
+ (setq default-directory dir)
+ (unless use-existing-buffer
+ (when (and svn-log-edit-file-name (file-readable-p svn-log-edit-file-name))
+ (insert-file svn-log-edit-file-name)))
+ (svn-log-edit-mode)))
+
+(defun svn-status-cleanup ()
+ (interactive)
+ (let ((file-names (svn-status-marked-file-names)))
+ (if file-names
+ (progn
+ ;(message "svn-status-cleanup %S" file-names))
+ (svn-run-svn t t 'cleanup (append (list "cleanup") file-names)))
+ (message "No valid file selected - No status cleanup possible"))))
+
+(defun svn-status-resolved ()
+ "Run `svn resolved' on all selected files.
+See `svn-status-marked-files' for what counts as selected."
+ (interactive)
+ (let* ((marked-files (svn-status-marked-files))
+ (num-of-files (length marked-files)))
+ (when (yes-or-no-p
+ (if (= 1 num-of-files)
+ (format "Resolve %s? " (svn-status-line-info->filename (car marked-files)))
+ (format "Resolve %d files? " num-of-files)))
+ (message "resolving: %S" (svn-status-marked-file-names))
+ (svn-status-create-arg-file svn-status-temp-arg-file "" (svn-status-marked-files) "")
+ (svn-run-svn t t 'resolved "resolved" "--targets" svn-status-temp-arg-file))))
+
+;; --------------------------------------------------------------------------------
+;; Update the *svn-status* buffer, when a file is saved
+;; --------------------------------------------------------------------------------
+
+(defvar svn-status-file-modified-after-save-flag ?m
+ "The flag, that is shown, in the *svn-status* buffer, after
+a file is changed and saved in emacs.
+Recommended values are ?m or ?M.")
+(defun svn-status-after-save-hook ()
+ "Set a modified indication, when a file is saved from a svn working copy."
+ (let* ((svn-dir (car-safe svn-status-directory-history))
+ (svn-dir (when svn-dir (expand-file-name svn-dir)))
+ (file-dir (file-name-directory (buffer-file-name)))
+ (svn-dir-len (length (or svn-dir "")))
+ (file-dir-len (length file-dir))
+ (file-name))
+ (when (and svn-dir
+ (>= file-dir-len svn-dir-len)
+ (string= (substring file-dir 0 svn-dir-len) svn-dir))
+ (setq file-name (substring (buffer-file-name) svn-dir-len))
+ ;;(message (format "In svn-status directory %S" file-name))
+ (let ((st-info svn-status-info)
+ (i-fname))
+ (while st-info
+ (setq i-fname (svn-status-line-info->filename (car st-info)))
+ ;;(message (format "i-fname=%S" i-fname))
+ (when (and (string= file-name i-fname)
+ (not (eq (svn-status-line-info->filemark (car st-info)) ??)))
+ (svn-status-line-info->set-filemark (car st-info)
+ svn-status-file-modified-after-save-flag)
+ (save-excursion
+ (set-buffer "*svn-status*")
+ (svn-status-goto-file-name i-fname)
+ (let ((buffer-read-only nil))
+ (delete-region (point-at-bol) (point-at-eol))
+ (svn-insert-line-in-status-buffer (car st-info))
+ (delete-char 1))))
+ (setq st-info (cdr st-info))))))
+ nil)
+
+(add-hook 'after-save-hook 'svn-status-after-save-hook)
+
+;; --------------------------------------------------------------------------------
+;; Getting older revisions
+;; --------------------------------------------------------------------------------
+
+(defun svn-status-get-specific-revision (arg)
+ "Retrieve older revisions.
+The older revisions are stored in backup files named F.~REVISION~.
+
+When the function is called without a prefix argument: get all marked files.
+Otherwise get only the actual file."
+ (interactive "P")
+ (svn-status-get-specific-revision-internal (not arg) t))
+
+(defun svn-status-get-specific-revision-internal (&optional only-actual-file arg)
+ (let* ((file-names (if only-actual-file
+ (list (svn-status-line-info->filename (svn-status-get-line-information)))
+ (svn-status-marked-file-names)))
+ (revision (if arg (svn-status-read-revision-string "Get files for version: " "PREV") "BASE"))
+ (file-name)
+ (file-name-with-revision))
+ (message "Getting revision %s for %S" revision file-names)
+ (setq svn-status-get-specific-revision-file-info nil)
+ (while file-names
+ (setq file-name (car file-names))
+ (setq file-name-with-revision (concat file-name ".~" revision "~"))
+ (add-to-list 'svn-status-get-specific-revision-file-info
+ (cons file-name file-name-with-revision))
+ (save-excursion
+ (find-file file-name-with-revision)
+ (setq buffer-read-only nil)
+ (delete-region (point-min) (point-max))
+ (svn-run-svn nil t 'cat (append (list "cat" "-r" revision) (list file-name)))
+ ;;todo: error processing
+ ;;svn: Filesystem has no item
+ ;;svn: file not found: revision `15', path `/trunk/file.txt'
+ (insert-buffer-substring "*svn-process*")
+ (save-buffer))
+ (setq file-names (cdr file-names)))
+ (setq svn-status-get-specific-revision-file-info
+ (nreverse svn-status-get-specific-revision-file-info))
+ (message "svn-status-get-specific-revision-file-info: %S"
+ svn-status-get-specific-revision-file-info)))
+
+
+(defun svn-status-ediff-with-revision (arg)
+ "Run ediff on the current file with a previous revision.
+If ARG then prompt for revision to diff against."
+ (interactive "P")
+ (svn-status-get-specific-revision-internal t arg)
+ (let* ((ediff-after-quit-destination-buffer (current-buffer))
+ (my-buffer (find-file-noselect (caar svn-status-get-specific-revision-file-info)))
+ (base-buff (find-file-noselect (cdar svn-status-get-specific-revision-file-info)))
+ (svn-transient-buffers (list base-buff ))
+ (startup-hook '(svn-ediff-startup-hook)))
+ (ediff-buffers my-buffer base-buff startup-hook)))
+
+(defun svn-ediff-startup-hook ()
+ (add-hook 'ediff-after-quit-hook-internal
+ `(lambda ()
+ (svn-ediff-exit-hook
+ ',ediff-after-quit-destination-buffer ',svn-transient-buffers))
+ nil 'local))
+
+(defun svn-ediff-exit-hook (svn-buf tmp-bufs)
+ ;; kill the temp buffers (and their associated windows)
+ (dolist (tb tmp-bufs)
+ (when (and tb (buffer-live-p tb) (not (buffer-modified-p tb)))
+ (let ((win (get-buffer-window tb t)))
+ (when win (delete-window win))
+ (kill-buffer tb))))
+ ;; switch back to the *svn* buffer
+ (when (and svn-buf (buffer-live-p svn-buf)
+ (not (get-buffer-window svn-buf t)))
+ (ignore-errors (switch-to-buffer svn-buf))))
+
+
+(defun svn-status-read-revision-string (prompt &optional default-value)
+ "Prompt the user for a svn revision number."
+ (interactive)
+ (read-string prompt default-value))
+
+;; --------------------------------------------------------------------------------
+;; SVN process handling
+;; --------------------------------------------------------------------------------
+
+(defun svn-process-kill ()
+ "Kill the current running svn process."
+ (interactive)
+ (let ((process (get-process "svn")))
+ (if process
+ (delete-process process)
+ (message "No running svn process"))))
+
+(defun svn-process-send-string (string)
+ "Send a string to the running svn process.
+This is useful, if the running svn process asks the user a question.
+Note: use C-q C-j to send a line termination character."
+ (interactive "sSend string to svn process: ")
+ (save-excursion
+ (set-buffer "*svn-process*")
+ (let ((buffer-read-only nil))
+ (insert string))
+ (set-marker (process-mark (get-process "svn")) (point)))
+ (process-send-string "svn" string))
+
+;; --------------------------------------------------------------------------------
+;; Property List stuff
+;; --------------------------------------------------------------------------------
+
+(defun svn-status-property-list ()
+ (interactive)
+ (let ((file-names (svn-status-marked-file-names)))
+ (if file-names
+ (progn
+ (svn-run-svn t t 'proplist (append (list "proplist" "-v") file-names)))
+ (message "No valid file selected - No property listing possible"))))
+
+(defun svn-status-proplist-start ()
+ (svn-run-svn t t 'proplist-parse "proplist" (svn-status-line-info->filename
+ (svn-status-get-line-information))))
+
+(defun svn-status-property-parse ()
+ (interactive)
+ (svn-status-proplist-start))
+
+(defun svn-status-property-edit-one-entry (arg)
+ "Edit a property.
+When called with a prefix argument, it is possible to enter a new property."
+ (interactive "P")
+ (setq svn-status-property-edit-must-match-flag (not arg))
+ (svn-status-proplist-start))
+
+(defun svn-status-property-set ()
+ (interactive)
+ (setq svn-status-property-edit-must-match-flag nil)
+ (svn-status-proplist-start))
+
+(defun svn-status-property-delete ()
+ (interactive)
+ (setq svn-status-property-edit-must-match-flag t)
+ (svn-status-proplist-start))
+
+(defun svn-status-property-parse-property-names ()
+ ;(svn-status-show-process-buffer-internal t)
+ (message "svn-status-property-parse-property-names")
+ (let ((pl)
+ (pfl)
+ (prop-name)
+ (prop-value))
+ (save-excursion
+ (set-buffer "*svn-process*")
+ (goto-char (point-min))
+ (forward-line 1)
+ (while (looking-at " \\(.+\\)")
+ (setq pl (append pl (list (match-string 1))))
+ (forward-line 1)))
+ ;(cond last-command: svn-status-property-set, svn-status-property-edit-one-entry
+ ;svn-status-property-parse:
+ (cond ((eq last-command 'svn-status-property-parse)
+ ;(message "%S %S" pl last-command)
+ (while pl
+ (svn-run-svn nil t 'propget-parse "propget" (car pl)
+ (svn-status-line-info->filename
+ (svn-status-get-line-information)))
+ (save-excursion
+ (set-buffer "*svn-process*")
+ (setq pfl (append pfl (list
+ (list
+ (car pl)
+ (buffer-substring
+ (point-min) (- (point-max) 1)))))))
+ (setq pl (cdr pl))
+ (message "%S" pfl)))
+ ((eq last-command 'svn-status-property-edit-one-entry)
+ ;;(message "svn-status-property-edit-one-entry")
+ (setq prop-name
+ (completing-read "Set Property - Name: " (mapcar 'list pl)
+ nil svn-status-property-edit-must-match-flag))
+ (unless (string= prop-name "")
+ (save-excursion
+ (set-buffer "*svn-status*")
+ (svn-status-property-edit (list (svn-status-get-line-information))
+ prop-name))))
+ ((eq last-command 'svn-status-property-set)
+ (message "svn-status-property-set")
+ (setq prop-name
+ (completing-read "Set Property - Name: " (mapcar 'list pl) nil nil))
+ (setq prop-value (read-from-minibuffer "Property value: "))
+ (unless (string= prop-name "")
+ (save-excursion
+ (set-buffer "*svn-status*")
+ (message "setting property %s := %s for %S" prop-name prop-value
+ (svn-status-marked-files)))))
+ ((eq last-command 'svn-status-property-delete)
+ (setq prop-name
+ (completing-read "Delete Property - Name: " (mapcar 'list pl) nil t))
+ (unless (string= prop-name "")
+ (save-excursion
+ (set-buffer "*svn-status*")
+ (let ((file-names (svn-status-marked-file-names)))
+ (when file-names
+ (message "Going to delete prop %s for %s" prop-name file-names)
+ (svn-run-svn t t 'propdel
+ (append (list "propdel" prop-name) file-names))))))))))
+
+(defun svn-status-property-edit (file-info-list prop-name &optional new-prop-value)
+ (let* ((commit-buffer (get-buffer-create "*svn-property-edit*"))
+ (dir default-directory)
+ ;; now only one file is implemented ...
+ (file-name (svn-status-line-info->filename (car file-info-list)))
+ (prop-value))
+ (message "Edit property %s for file %s" prop-name file-name)
+ (svn-run-svn nil t 'propget-parse "propget" prop-name file-name)
+ (save-excursion
+ (set-buffer "*svn-process*")
+ (setq prop-value (if (> (point-max) 1)
+ (buffer-substring (point-min) (- (point-max) 1))
+ "")))
+ (setq svn-status-propedit-property-name prop-name)
+ (setq svn-status-propedit-file-list file-info-list)
+ (setq svn-status-pre-propedit-window-configuration (current-window-configuration))
+ (pop-to-buffer commit-buffer)
+ (delete-region (point-min) (point-max))
+ (setq default-directory dir)
+ (insert prop-value)
+ (svn-status-remove-control-M)
+ (when new-prop-value
+ (when (listp new-prop-value)
+ (message "Adding new prop values %S " new-prop-value)
+ (while new-prop-value
+ (goto-char (point-min))
+ (unless (re-search-forward
+ (concat "^" (regexp-quote (car new-prop-value)) "$") nil t)
+ (goto-char (point-max))
+ (when (> (current-column) 0) (insert "\n"))
+ (insert (car new-prop-value)))
+ (setq new-prop-value (cdr new-prop-value)))))
+ (svn-prop-edit-mode)))
+
+(defun svn-status-property-set-property (file-info-list prop-name prop-value)
+ "Set a property on a given file list."
+ (save-excursion
+ (set-buffer (get-buffer "*svn-property-edit*"))
+ (delete-region (point-min) (point-max))
+ (insert prop-value))
+ (setq svn-status-propedit-file-list (svn-status-marked-files))
+ (setq svn-status-propedit-property-name prop-name)
+ (svn-prop-edit-do-it nil)
+ (svn-status-update))
+
+
+(defun svn-status-get-directory (line-info)
+ (let* ((file-name (svn-status-line-info->filename line-info))
+ (file-dir (file-name-directory file-name)))
+ ;;(message "file-dir: %S" file-dir)
+ (if file-dir
+ (substring file-dir 0 (- (length file-dir) 1))
+ ".")))
+
+(defun svn-status-get-file-list-per-directory (files)
+ ;;(message "%S" files)
+ (let ((dir-list nil)
+ (i files)
+ (j)
+ (dir))
+ (while i
+ (setq dir (svn-status-get-directory (car i)))
+ (setq j (assoc dir dir-list))
+ (if j
+ (progn
+ ;;(message "dir already present %S %s" j dir)
+ (setcdr j (append (cdr j) (list (car i)))))
+ (setq dir-list (append dir-list (list (list dir (car i))))))
+ (setq i (cdr i)))
+ ;;(message "svn-status-get-file-list-per-directory: %S" dir-list)
+ dir-list))
+
+(defun svn-status-property-ignore-file ()
+ (interactive)
+ (let ((d-list (svn-status-get-file-list-per-directory (svn-status-marked-files)))
+ (dir)
+ (f-info)
+ (ext-list))
+ (while d-list
+ (setq dir (caar d-list))
+ (setq f-info (cdar d-list))
+ (setq ext-list (mapcar '(lambda (i)
+ (svn-status-line-info->filename-nondirectory i)) f-info))
+ ;;(message "ignore in dir %s: %S" dir f-info)
+ (save-window-excursion
+ (when (y-or-n-p (format "Ignore %S for %s? " ext-list dir))
+ (svn-status-property-edit
+ (list (svn-status-find-info-for-file-name dir)) "svn:ignore" ext-list)
+ (svn-prop-edit-do-it nil))) ; synchronous
+ (setq d-list (cdr d-list)))
+ (svn-status-update)))
+
+(defun svn-status-property-ignore-file-extension ()
+ (interactive)
+ (let ((d-list (svn-status-get-file-list-per-directory (svn-status-marked-files)))
+ (dir)
+ (f-info)
+ (ext-list))
+ (while d-list
+ (setq dir (caar d-list))
+ (setq f-info (cdar d-list))
+ ;;(message "ignore in dir %s: %S" dir f-info)
+ (setq ext-list nil)
+ (while f-info
+ (add-to-list 'ext-list (concat "*."
+ (file-name-extension
+ (svn-status-line-info->filename (car f-info)))))
+ (setq f-info (cdr f-info)))
+ ;;(message "%S" ext-list)
+ (save-window-excursion
+ (when (y-or-n-p (format "Ignore %S for %s? " ext-list dir))
+ (svn-status-property-edit
+ (list (svn-status-find-info-for-file-name dir)) "svn:ignore"
+ ext-list)
+ (svn-prop-edit-do-it nil)))
+ (setq d-list (cdr d-list)))
+ (svn-status-update)))
+
+(defun svn-status-property-edit-svn-ignore ()
+ (interactive)
+ (let* ((line-info (svn-status-get-line-information))
+ (dir (if (svn-status-line-info->directory-p line-info)
+ (svn-status-line-info->filename line-info)
+ (svn-status-get-directory line-info))))
+ (svn-status-property-edit
+ (list (svn-status-find-info-for-file-name dir)) "svn:ignore")
+ (message "Edit svn:ignore on %s" dir)))
+
+
+(defun svn-status-property-set-keyword-list ()
+ "Edit the svn:keywords property on the marked files."
+ (interactive)
+ ;;(message "Set svn:keywords for %S" (svn-status-marked-file-names))
+ (svn-status-property-edit (svn-status-marked-files) "svn:keywords"))
+
+(defun svn-status-property-set-eol-style ()
+ "Edit the svn:eol-style property on the marked files."
+ (interactive)
+ (svn-status-property-set-property
+ (svn-status-marked-files) "svn:eol-style"
+ (completing-read "Set svn:eol-style for the marked files: "
+ (mapcar 'list '("native" "CRLF" "LF" "CR"))
+ nil t)))
+
+;; --------------------------------------------------------------------------------
+;; svn-prop-edit-mode:
+;; --------------------------------------------------------------------------------
+
+(defvar svn-prop-edit-mode-map () "Keymap used in `svn-prop-edit-mode' buffers.")
+
+(when (not svn-prop-edit-mode-map)
+ (setq svn-prop-edit-mode-map (make-sparse-keymap))
+ (define-key svn-prop-edit-mode-map [(control ?c) (control ?c)] 'svn-prop-edit-done)
+ (define-key svn-prop-edit-mode-map [(control ?c) (control ?d)] 'svn-prop-edit-svn-diff)
+ (define-key svn-prop-edit-mode-map [(control ?c) (control ?s)] 'svn-prop-edit-svn-status)
+ (define-key svn-prop-edit-mode-map [(control ?c) (control ?l)] 'svn-prop-edit-svn-log)
+ (define-key svn-prop-edit-mode-map [(control ?c) (control ?q)] 'svn-prop-edit-abort))
+
+(easy-menu-define svn-prop-edit-mode-menu svn-prop-edit-mode-map
+"'svn-prop-edit-mode' menu"
+ '("SVN-PropEdit"
+ ["Commit" svn-prop-edit-done t]
+ ["Show Diff" svn-prop-edit-svn-diff t]
+ ["Show Status" svn-prop-edit-svn-status t]
+ ["Show Log" svn-prop-edit-svn-log t]
+ ["Abort" svn-prop-edit-abort t]))
+
+(defun svn-prop-edit-mode ()
+ "Major Mode to edit file properties of files under svn control.
+Commands:
+\\{svn-prop-edit-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map svn-prop-edit-mode-map)
+ (easy-menu-add svn-prop-edit-mode-menu)
+ (setq major-mode 'svn-prop-edit-mode)
+ (setq mode-name "svn-prop-edit"))
+
+(defun svn-prop-edit-abort ()
+ (interactive)
+ (bury-buffer)
+ (set-window-configuration svn-status-pre-propedit-window-configuration))
+
+(defun svn-prop-edit-done ()
+ (interactive)
+ (svn-prop-edit-do-it t))
+
+(defun svn-prop-edit-do-it (async)
+ (message "svn propset %s on %s"
+ svn-status-propedit-property-name
+ (mapcar 'svn-status-line-info->filename svn-status-propedit-file-list))
+ (save-excursion
+ (set-buffer (get-buffer "*svn-property-edit*"))
+ (set-buffer-file-coding-system 'undecided-unix nil)
+ (setq svn-status-temp-file-to-remove
+ (concat svn-status-temp-dir "svn-prop-edit.txt" svn-temp-suffix))
+ (write-region (point-min) (point-max) svn-status-temp-file-to-remove nil 1))
+ (when svn-status-propedit-file-list ; there are files to change properties
+ (svn-status-create-arg-file svn-status-temp-arg-file ""
+ svn-status-propedit-file-list "")
+ (setq svn-status-propedit-file-list nil)
+ (svn-run-svn async t 'propset "propset"
+ svn-status-propedit-property-name
+ "--targets" svn-status-temp-arg-file
+ "-F" (concat svn-status-temp-dir "svn-prop-edit.txt" svn-temp-suffix))
+ (unless async (svn-status-remove-temp-file-maybe)))
+ (set-window-configuration svn-status-pre-propedit-window-configuration))
+
+(defun svn-prop-edit-svn-diff (arg)
+ (interactive "P")
+ (set-buffer "*svn-status*")
+ (svn-status-show-svn-diff-for-marked-files arg))
+
+(defun svn-prop-edit-svn-log (arg)
+ (interactive "P")
+ (set-buffer "*svn-status*")
+ (svn-status-show-svn-log arg))
+
+(defun svn-prop-edit-svn-status ()
+ (interactive)
+ (pop-to-buffer "*svn-status*")
+ (other-window 1))
+
+;; --------------------------------------------------------------------------------
+;; svn-log-edit-mode:
+;; --------------------------------------------------------------------------------
+
+(defvar svn-log-edit-mode-map () "Keymap used in `svn-log-edit-mode' buffers.")
+
+(when (not svn-log-edit-mode-map)
+ (setq svn-log-edit-mode-map (make-sparse-keymap))
+ (define-key svn-log-edit-mode-map (kbd "C-c C-c") 'svn-log-edit-done)
+ (define-key svn-log-edit-mode-map (kbd "C-c C-d") 'svn-log-edit-svn-diff)
+ (define-key svn-log-edit-mode-map (kbd "C-c C-s") 'svn-log-edit-save-message)
+ (define-key svn-log-edit-mode-map (kbd "C-c C-i") 'svn-log-edit-svn-status)
+ (define-key svn-log-edit-mode-map (kbd "C-c C-l") 'svn-log-edit-svn-log)
+ (define-key svn-log-edit-mode-map (kbd "C-c C-?") 'svn-log-edit-show-files-to-commit)
+ (define-key svn-log-edit-mode-map (kbd "C-c C-z") 'svn-log-edit-erase-edit-buffer)
+ (define-key svn-log-edit-mode-map (kbd "C-c C-q") 'svn-log-edit-abort))
+
+(easy-menu-define svn-log-edit-mode-menu svn-log-edit-mode-map
+"'svn-log-edit-mode' menu"
+ '("SVN-Log"
+ ["Save to disk" svn-log-edit-save-message t]
+ ["Commit" svn-log-edit-done t]
+ ["Show Diff" svn-log-edit-svn-diff t]
+ ["Show Status" svn-log-edit-svn-status t]
+ ["Show Log" svn-log-edit-svn-log t]
+ ["Show files to commit" svn-log-edit-show-files-to-commit t]
+ ["Erase buffer" svn-log-edit-erase-edit-buffer]
+ ["Abort" svn-log-edit-abort t]))
+
+(defun svn-log-edit-mode ()
+ "Major Mode to edit svn log messages.
+Commands:
+\\{svn-log-edit-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (use-local-map svn-log-edit-mode-map)
+ (easy-menu-add svn-log-edit-mode-menu)
+ (setq major-mode 'svn-log-edit-mode)
+ (setq mode-name "svn-log-edit")
+ (run-hooks 'svn-log-edit-mode-hook))
+
+(defun svn-log-edit-abort ()
+ (interactive)
+ (bury-buffer)
+ (set-window-configuration svn-status-pre-commit-window-configuration))
+
+(defun svn-log-edit-done ()
+ (interactive)
+ (message "svn-log editing done")
+ (save-excursion
+ (set-buffer (get-buffer "*svn-log-edit*"))
+ (set-buffer-file-coding-system 'undecided-unix nil)
+ (write-region (point-min) (point-max)
+ (concat svn-status-temp-dir "svn-log-edit.txt" svn-temp-suffix) nil 1))
+ (when svn-status-files-to-commit ; there are files to commit
+ (svn-status-create-arg-file svn-status-temp-arg-file ""
+ svn-status-files-to-commit "")
+ (setq svn-status-files-to-commit nil)
+ (setq svn-status-temp-file-to-remove (concat svn-status-temp-dir "svn-log-edit.txt" svn-temp-suffix))
+ (svn-run-svn t t 'commit "commit" "--targets" svn-status-temp-arg-file
+ "-F" svn-status-temp-file-to-remove))
+ (set-window-configuration svn-status-pre-commit-window-configuration))
+
+(defun svn-log-edit-svn-diff (arg)
+ "Show the diff we are about to commit.
+If ARG then show diff between some other version of the selected files."
+ (interactive "P")
+ (set-buffer "*svn-status*")
+ (svn-status-show-svn-diff-for-marked-files arg))
+
+(defun svn-log-edit-svn-log (arg)
+ (interactive "P")
+ (set-buffer "*svn-status*")
+ (svn-status-show-svn-log arg))
+
+(defun svn-log-edit-svn-status ()
+ (interactive)
+ (pop-to-buffer "*svn-status*")
+ (other-window 1))
+
+(defun svn-log-edit-show-files-to-commit ()
+ (interactive)
+ (message "Files to commit: %S"
+ (mapcar 'svn-status-line-info->filename svn-status-files-to-commit)))
+
+(defun svn-log-edit-save-message ()
+ "Save the current log message to the file `svn-log-edit-file-name'."
+ (interactive)
+ (write-region (point-min) (point-max) svn-log-edit-file-name))
+
+(defun svn-log-edit-erase-edit-buffer ()
+ "Delete everything in the *svn-log-edit* buffer."
+ (interactive)
+ (set-buffer "*svn-log-edit*")
+ (erase-buffer))
+
+
+;; --------------------------------------------------------------------------------
+;; svn-log-view-mode:
+;; --------------------------------------------------------------------------------
+
+(defvar svn-log-view-mode-map () "Keymap used in `svn-log-view-mode' buffers.")
+
+(when (not svn-log-view-mode-map)
+ (setq svn-log-view-mode-map (make-sparse-keymap))
+ (define-key svn-log-view-mode-map (kbd "p") 'svn-log-view-prev)
+ (define-key svn-log-view-mode-map (kbd "n") 'svn-log-view-next)
+ (define-key svn-log-view-mode-map (kbd "=") 'svn-log-view-diff)
+ (define-key svn-log-view-mode-map (kbd "q") 'bury-buffer))
+(easy-menu-define svn-log-view-mode-menu svn-log-view-mode-map
+"'svn-log-view-mode' menu"
+ '("SVN-LogView"
+ ["Show Changeset" svn-log-view-diff t]))
+
+(defvar svn-log-view-font-lock-keywords
+ '(("^r.+" . font-lock-keyword-face)
+ "Keywords in svn-log-view-mode."))
+
+(define-derived-mode svn-log-view-mode log-view-mode "svn-log-view"
+ "Major Mode to show the output from svn log.
+Commands:
+\\{svn-log-view-mode-map}
+"
+ (use-local-map svn-log-view-mode-map)
+ (easy-menu-add svn-log-view-mode-menu)
+ (set (make-local-variable 'font-lock-defaults) '(svn-log-view-font-lock-keywords t)))
+
+(defun svn-log-view-next ()
+ (interactive)
+ (when (re-search-forward "^r[0-9]+" nil t)
+ (beginning-of-line 3)))
+
+(defun svn-log-view-prev ()
+ (interactive)
+ (when (re-search-backward "^r[0-9]+" nil t 2)
+ (beginning-of-line 3)))
+
+(defun svn-log-revision-at-point ()
+ (save-excursion
+ (re-search-backward "^r\\([0-9]+\\)")
+ (match-string-no-properties 1)))
+
+(defun svn-log-view-diff (arg)
+ "Show the changeset for a given log entry.
+When called with a prefix argument, ask the user for the revision."
+ (interactive "P")
+ (let* ((upper-rev (svn-log-revision-at-point))
+ (lower-rev (number-to-string (- (string-to-number upper-rev) 1)))
+ (rev-arg (concat lower-rev ":" upper-rev)))
+ (when arg
+ (setq rev-arg (read-string "Revision for changeset: " rev-arg)))
+ (svn-run-svn nil t 'diff "diff" (concat "-r" rev-arg))
+ (svn-status-show-process-buffer-internal t)
+ (save-excursion
+ (set-buffer "*svn-process*")
+ (diff-mode)
+ (font-lock-fontify-buffer))))
+
+(provide 'psvn)
+
+;;; psvn.el ends here
projects / lib.git / commitdiff