From: Don Armstrong Date: Sat, 1 Oct 2005 10:39:48 +0000 (+0000) Subject: Initial user home directory commit X-Git-Url: https://git.donarmstrong.com/?p=lib.git;a=commitdiff_plain;h=dfabe3732e6bcdce91dff00dbfb916e9c932396e Initial user home directory commit --- dfabe3732e6bcdce91dff00dbfb916e9c932396e diff --git a/emacs_el/bibtex.el b/emacs_el/bibtex.el new file mode 100644 index 0000000..fd50e01 --- /dev/null +++ b/emacs_el/bibtex.el @@ -0,0 +1,4073 @@ +;;; bibtex.el --- BibTeX mode for GNU Emacs + +;; Copyright (C) 1992, 1994, 1995, 1996, 1997, 1998, 1999 Free Software Foundation, Inc. + +;; Author: Stefan Schoef +;; Bengt Martensson +;; Mark Shapiro +;; Mike Newton +;; Aaron Larson +;; 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)) + + +;; Bug Reporting + +(defconst + bibtex-maintainer-address "Dirk Herrmann ") +;; current maintainer + +(defconst + bibtex-maintainer-salutation "Hallo Dirk,") +;; current maintainer + +(defconst + bibtex-version "(emacs 20.4)") +;; current version of the bibtex.el file + + +;; 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. + +;; 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))) + + +;; 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)) + + +;; 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])) + + +;; 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 + + +;; 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 . +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 + + + +;; 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)) + + +;; 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)) + + +;; Make BibTeX a Feature + +(provide 'bibtex) + +;;; bibtex.el ends here diff --git a/emacs_el/cperl-mode.el b/emacs_el/cperl-mode.el new file mode 100644 index 0000000..a0394a9 --- /dev/null +++ b/emacs_el/cperl-mode.el @@ -0,0 +1,8464 @@ +;;; cperl-mode.el --- Perl code editing commands for Emacs + +;; Copyright (C) 1985, 86, 87, 91, 92, 93, 94, 95, 96, 97, 98, 99, 2000, 2003 +;; Free Software Foundation, Inc. + +;; Author: Ilya Zakharevich and Bob Olson +;; Maintainer: Ilya Zakharevich +;; Keywords: languages, Perl + +;; This file is part of GNU Emacs. + +;;; This code started from the following message of long time ago +;;; (IZ), but Bob does not maintain this mode any more: + +;;; From: olson@mcs.anl.gov (Bob Olson) +;;; Newsgroups: comp.lang.perl +;;; Subject: cperl-mode: Another perl mode for Gnuemacs +;;; Date: 14 Aug 91 15:20:01 GMT + +;; Copyright (C) Ilya Zakharevich and Bob Olson + +;; This file may be distributed +;; either under the same terms as GNU Emacs, or under the same terms +;; as Perl. You should have received a copy of Perl Artistic license +;; along with the Perl distribution. + +;; 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. + +;;; Corrections made by Ilya Zakharevich cperl@ilyaz.org +;;; XEmacs changes by Peter Arius arius@informatik.uni-erlangen.de + +;;; Commentary: + +;; $Id: cperl-mode.el,v 5.0 2003/02/17 01:33:20 vera Exp vera $ + +;;; If your Emacs does not default to `cperl-mode' on Perl files: +;;; To use this mode put the following into +;;; your .emacs file: + +;; (autoload 'perl-mode "cperl-mode" "alternate mode for editing Perl programs" t) + +;; You can either fine-tune the bells and whistles of this mode or +;; bulk enable them by putting + +;; (setq cperl-hairy t) + +;; in your .emacs file. (Emacs rulers do not consider it politically +;; correct to make whistles enabled by default.) + +;; DO NOT FORGET to read micro-docs (available from `Perl' menu) <<<<<< +;; or as help on variables `cperl-tips', `cperl-problems', <<<<<< +;; `cperl-non-problems', `cperl-praise', `cperl-speed'. <<<<<< + +;; Additional useful commands to put into your .emacs file (before +;; RMS Emacs 20.3): + +;; (setq auto-mode-alist +;; (append '(("\\.\\([pP][Llm]\\|al\\)$" . perl-mode)) auto-mode-alist )) +;; (setq interpreter-mode-alist (append interpreter-mode-alist +;; '(("miniperl" . perl-mode)))) + +;; The mode information (on C-h m) provides some customization help. +;; If you use font-lock feature of this mode, it is advisable to use +;; either lazy-lock-mode or fast-lock-mode. I prefer lazy-lock. + +;; Faces used now: three faces for first-class and second-class keywords +;; and control flow words, one for each: comments, string, labels, +;; functions definitions and packages, arrays, hashes, and variable +;; definitions. If you do not see all these faces, your font-lock does +;; not define them, so you need to define them manually. +;; Maybe you have an obsolete font-lock from 19.28 or earlier. Upgrade. + +;; If you have a grayscale monitor, and do not have the variable +;; font-lock-display-type bound to 'grayscale, insert + +;; (setq font-lock-display-type 'grayscale) + +;; into your .emacs file (this is relevant before RMS Emacs 20). + +;; This mode supports font-lock, imenu and mode-compile. In the +;; hairy version font-lock is on, but you should activate imenu +;; yourself (note that mode-compile is not standard yet). Well, you +;; can use imenu from keyboard anyway (M-x imenu), but it is better +;; to bind it like that: + +;; (define-key global-map [M-S-down-mouse-3] 'imenu) + +;;; Font lock bugs as of v4.32: + +;; The following kinds of Perl code erroneously start strings: +;; \$` \$' \$" +;; $opt::s $opt_s $opt{s} (s => ...) /\s+.../ +;; likewise with m, tr, y, q, qX instead of s + +;;; In fact the version of font-lock that this version supports can be +;;; much newer than the version you actually have. This means that a +;;; lot of faces can be set up, but are not visible on your screen +;;; since the coloring rules for this faces are not defined. + +;;; Updates: ======================================== + +;;; Made less hairy by default: parentheses not electric, +;;; linefeed not magic. Bug with abbrev-mode corrected. + +;;;; After 1.4: +;;; Better indentation: +;;; subs inside braces should work now, +;;; Toplevel braces obey customization. +;;; indent-for-comment knows about bad cases, cperl-indent-for-comment +;;; moves cursor to a correct place. +;;; cperl-indent-exp written from the scratch! Slow... (quadratic!) :-( +;;; (50 secs on DB::DB (sub of 430 lines), 486/66) +;;; Minor documentation fixes. +;;; Imenu understands packages as prefixes (including nested). +;;; Hairy options can be switched off one-by-one by setting to null. +;;; Names of functions and variables changed to conform to `cperl-' style. + +;;;; After 1.5: +;;; Some bugs with indentation of labels (and embedded subs) corrected. +;;; `cperl-indent-region' done (slow :-()). +;;; `cperl-fill-paragraph' done. +;;; Better package support for `imenu'. +;;; Progress indicator for indentation (with `imenu' loaded). +;;; `Cperl-set' was busted, now setting the individual hairy option +;;; should be better. + +;;;; After 1.6: +;;; `cperl-set-style' done. +;;; `cperl-check-syntax' done. +;;; Menu done. +;;; New config variables `cperl-close-paren-offset' and `cperl-comment-column'. +;;; Bugs with `cperl-auto-newline' corrected. +;;; `cperl-electric-lbrace' can work with `cperl-auto-newline' in situation +;;; like $hash{. + +;;;; 1.7 XEmacs (arius@informatik.uni-erlangen.de): +;;; - use `next-command-event', if `next-command-events' does not exist +;;; - use `find-face' as def. of `is-face' +;;; - corrected def. of `x-color-defined-p' +;;; - added const defs for font-lock-comment-face, +;;; font-lock-keyword-face and font-lock-function-name-face +;;; - added def. of font-lock-variable-name-face +;;; - added (require 'easymenu) inside an `eval-when-compile' +;;; - replaced 4-argument `substitute-key-definition' with ordinary +;;; `define-key's +;;; - replaced `mark-active' in menu definition by `cperl-use-region-p'. +;;; Todo (at least): +;;; - use emacs-vers.el (http://www.cs.utah.edu/~eeide/emacs/emacs-vers.el.gz) +;;; for portable code? +;;; - should `cperl-mode' do a +;;; (if (featurep 'easymenu) (easy-menu-add cperl-menu)) +;;; or should this be left to the user's `cperl-mode-hook'? + +;;; Some bugs introduced by the above fix corrected (IZ ;-). +;;; Some bugs under XEmacs introduced by the correction corrected. + +;;; Some more can remain since there are two many different variants. +;;; Please feedback! + +;;; We do not support fontification of arrays and hashes under +;;; obsolete font-lock any more. Upgrade. + +;;;; after 1.8 Minor bug with parentheses. +;;;; after 1.9 Improvements from Joe Marzot. +;;;; after 1.10 +;;; Does not need easymenu to compile under XEmacs. +;;; `vc-insert-headers' should work better. +;;; Should work with 19.29 and 19.12. +;;; Small improvements to fontification. +;;; Expansion of keywords does not depend on C-? being backspace. + +;;; after 1.10+ +;;; 19.29 and 19.12 supported. +;;; `cperl-font-lock-enhanced' deprecated. Use font-lock-extra.el. +;;; Support for font-lock-extra.el. + +;;;; After 1.11: +;;; Tools submenu. +;;; Support for perl5-info. +;;; `imenu-go-find-at-position' in Tools requires imenu-go.el (see hints above) +;;; Imenu entries do not work with stock imenu.el. Patch sent to maintainers. +;;; Fontifies `require a if b;', __DATA__. +;;; Arglist for auto-fill-mode was incorrect. + +;;;; After 1.12: +;;; `cperl-lineup-step' and `cperl-lineup' added: lineup constructions +;;; vertically. +;;; `cperl-do-auto-fill' updated for 19.29 style. +;;; `cperl-info-on-command' now has a default. +;;; Workaround for broken C-h on XEmacs. +;;; VC strings escaped. +;;; C-h f now may prompt for function name instead of going on, +;;; controlled by `cperl-info-on-command-no-prompt'. + +;;;; After 1.13: +;;; Msb buffer list includes perl files +;;; Indent-for-comment uses indent-to +;;; Can write tag files using etags. + +;;;; After 1.14: +;;; Recognizes (tries to ;-) {...} which are not blocks during indentation. +;;; `cperl-close-paren-offset' affects ?\] too (and ?\} if not block) +;;; Bug with auto-filling comments started with "##" corrected. + +;;;; Very slow now: on DB::DB 0.91, 486/66: + +;;;Function Name Call Count Elapsed Time Average Time +;;;======================================== ========== ============ ============ +;;;cperl-block-p 469 3.7799999999 0.0080597014 +;;;cperl-get-state 505 163.39000000 0.3235445544 +;;;cperl-comment-indent 12 0.0299999999 0.0024999999 +;;;cperl-backward-to-noncomment 939 4.4599999999 0.0047497337 +;;;cperl-calculate-indent 505 172.22000000 0.3410297029 +;;;cperl-indent-line 505 172.88000000 0.3423366336 +;;;cperl-use-region-p 40 0.0299999999 0.0007499999 +;;;cperl-indent-exp 1 177.97000000 177.97000000 +;;;cperl-to-comment-or-eol 1453 3.9800000000 0.0027391603 +;;;cperl-backward-to-start-of-continued-exp 9 0.0300000000 0.0033333333 +;;;cperl-indent-region 1 177.94000000 177.94000000 + +;;;; After 1.15: +;;; Takes into account white space after opening parentheses during indent. +;;; May highlight pods and here-documents: see `cperl-pod-here-scan', +;;; `cperl-pod-here-fontify', `cperl-pod-face'. Does not use this info +;;; for indentation so far. +;;; Fontification updated to 19.30 style. +;;; The change 19.29->30 did not add all the required functionality, +;;; but broke "font-lock-extra.el". Get "choose-color.el" from +;;; ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs + +;;;; After 1.16: +;;; else # comment +;;; recognized as a start of a block. +;;; Two different font-lock-levels provided. +;;; `cperl-pod-head-face' introduced. Used for highlighting. +;;; `imenu' marks pods, +Packages moved to the head. + +;;;; After 1.17: +;;; Scan for pods highlights here-docs too. +;;; Note that the tag of here-doc may be rehighlighted later by lazy-lock. +;;; Only one here-doc-tag per line is supported, and one in comment +;;; or a string may break fontification. +;;; POD headers were supposed to fill one line only. + +;;;; After 1.18: +;;; `font-lock-keywords' were set in 19.30 style _always_. Current scheme +;;; may break under XEmacs. +;;; `cperl-calculate-indent' dis suppose that `parse-start' was defined. +;;; `fontified' tag is added to fontified text as well as `lazy-lock' (for +;;; compatibility with older lazy-lock.el) (older one overfontifies +;;; something nevertheless :-(). +;;; Will not indent something inside pod and here-documents. +;;; Fontifies the package name after import/no/bootstrap. +;;; Added new entry to menu with meta-info about the mode. + +;;;; After 1.19: +;;; Prefontification works much better with 19.29. Should be checked +;;; with 19.30 as well. +;;; Some misprints in docs corrected. +;;; Now $a{-text} and -text => "blah" are fontified as strings too. +;;; Now the pod search is much stricter, so it can help you to find +;;; pod sections which are broken because of whitespace before =blah +;;; - just observe the fontification. + +;;;; After 1.20 +;;; Anonymous subs are indented with respect to the level of +;;; indentation of `sub' now. +;;; {} is recognized as hash after `bless' and `return'. +;;; Anonymous subs are split by `cperl-linefeed' as well. +;;; Electric parens embrace a region if present. +;;; To make `cperl-auto-newline' useful, +;;; `cperl-auto-newline-after-colon' is introduced. +;;; `cperl-electric-parens' is now t or nul. The old meaning is moved to +;;; `cperl-electric-parens-string'. +;;; `cperl-toggle-auto-newline' introduced, put on C-c C-a. +;;; `cperl-toggle-abbrev' introduced, put on C-c C-k. +;;; `cperl-toggle-electric' introduced, put on C-c C-e. +;;; Beginning-of-defun-regexp was not anchored. + +;;;; After 1.21 +;;; Auto-newline grants `cperl-extra-newline-before-brace' if "{" is typed +;;; after ")". +;;; {} is recognized as expression after `tr' and friends. + +;;;; After 1.22 +;;; Entry Hierarchy added to imenu. Very primitive so far. +;;; One needs newer `imenu-go'.el. A patch to `imenu' is needed as well. +;;; Writes its own TAGS files. +;;; Class viewer based on TAGS files. Does not trace @ISA so far. +;;; 19.31: Problems with scan for PODs corrected. +;;; First POD header correctly fontified. +;;; I needed (setq imenu-use-keymap-menu t) to get good imenu in 19.31. +;;; Apparently it makes a lot of hierarchy code obsolete... + +;;;; After 1.23 +;;; Tags filler now scans *.xs as well. +;;; The info from *.xs scan is used by the hierarchy viewer. +;;; Hierarchy viewer documented. +;;; Bug in 19.31 imenu documented. + +;;;; After 1.24 +;;; New location for info-files mentioned, +;;; Electric-; should work better. +;;; Minor bugs with POD marking. + +;;;; After 1.25 (probably not...) +;;; `cperl-info-page' introduced. +;;; To make `uncomment-region' working, `comment-region' would +;;; not insert extra space. +;;; Here documents delimiters better recognized +;;; (empty one, and non-alphanums in quotes handled). May be wrong with 1<<14? +;;; `cperl-db' added, used in menu. +;;; imenu scan removes text-properties, for better debugging +;;; - but the bug is in 19.31 imenu. +;;; formats highlighted by font-lock and prescan, embedded comments +;;; are not treated. +;;; POD/friends scan merged in one pass. +;;; Syntax class is not used for analyzing the code, only char-syntax +;;; may be checked against _ or'ed with w. +;;; Syntax class of `:' changed to be _. +;;; `cperl-find-bad-style' added. + +;;;; After 1.25 +;;; When search for here-documents, we ignore commented << in simplest cases. +;;; `cperl-get-help' added, available on C-h v and from menu. +;;; Auto-help added. Default with `cperl-hairy', switchable on/off +;;; with startup variable `cperl-lazy-help-time' and from +;;; menu. Requires `run-with-idle-timer'. +;;; Highlighting of @abc{@efg} was wrong - interchanged two regexps. + +;;;; After 1.27 +;;; Indentation: At toplevel after a label - fixed. +;;; 1.27 was put to archives in binary mode ===> DOSish :-( + +;;;; After 1.28 +;;; Thanks to Martin Buchholz : misprints in +;;; comments and docstrings corrected, XEmacs support cleaned up. +;;; The closing parenths would enclose the region into matching +;;; parens under the same conditions as the opening ones. +;;; Minor updates to `cperl-short-docs'. +;;; Will not consider <<= as start of here-doc. + +;;;; After 1.29 +;;; Added an extra advice to look into Micro-docs. ;-). +;;; Enclosing of region when you press a closing parenth is regulated by +;;; `cperl-electric-parens-string'. +;;; Minor updates to `cperl-short-docs'. +;;; `initialize-new-tags-table' called only if present (Does this help +;;; with generation of tags under XEmacs?). +;;; When creating/updating tag files, new info is written at the old place, +;;; or at the end (is this a wanted behaviour? I need this in perl build directory). + +;;;; After 1.30 +;;; All the keywords from keywords.pl included (maybe with dummy explanation). +;;; No auto-help inside strings, comment, here-docs, formats, and pods. +;;; Shrinkwrapping of info, regulated by `cperl-max-help-size', +;;; `cperl-shrink-wrap-info-frame'. +;;; Info on variables as well. +;;; Recognision of HERE-DOCS improved yet more. +;;; Autonewline works on `}' without warnings. +;;; Autohelp works again on $_[0]. + +;;;; After 1.31 +;;; perl-descr.el found its author - hi, Johan! +;;; Some support for correct indent after here-docs and friends (may +;;; be superseeded by eminent change to Emacs internals). +;;; Should work with older Emaxen as well ( `-style stuff removed). + +;;;; After 1.32 + +;;; Started to add support for `syntax-table' property (should work +;;; with patched Emaxen), controlled by +;;; `cperl-use-syntax-table-text-property'. Currently recognized: +;;; All quote-like operators: m, s, y, tr, qq, qw, qx, q, +;;; // in most frequent context: +;;; after block or +;;; ~ { ( = | & + - * ! , ; +;;; or +;;; while if unless until and or not xor split grep map +;;; Here-documents, formats, PODs, +;;; ${...} +;;; 'abc$' +;;; sub a ($); sub a ($) {} +;;; (provide 'cperl-mode) was missing! +;;; `cperl-after-expr-p' is now much smarter after `}'. +;;; `cperl-praise' added to mini-docs. +;;; Utilities try to support subs-with-prototypes. + +;;;; After 1.32.1 +;;; `cperl-after-expr-p' is now much smarter after "() {}" and "word {}": +;;; if word is "else, map, grep". +;;; Updated for new values of syntax-table constants. +;;; Uses `help-char' (at last!) (disabled, does not work?!) +;;; A couple of regexps where missing _ in character classes. +;;; -s could be considered as start of regexp, 1../blah/ was not, +;;; as was not /blah/ at start of file. + +;;;; After 1.32.2 +;;; "\C-hv" was wrongly "\C-hf" +;;; C-hv was not working on `[index()]' because of [] in skip-chars-*. +;;; `__PACKAGE__' supported. +;;; Thanks for Greg Badros: `cperl-lazy-unstall' is more complete, +;;; `cperl-get-help' is made compatible with `query-replace'. + +;;;; As of Apr 15, development version of 19.34 supports +;;;; `syntax-table' text properties. Try setting +;;;; `cperl-use-syntax-table-text-property'. + +;;;; After 1.32.3 +;;; We scan for s{}[] as well (in simplest situations). +;;; We scan for $blah'foo as well. +;;; The default is to use `syntax-table' text property if Emacs is good enough. +;;; `cperl-lineup' is put on C-M-| (=C-M-S-\\). +;;; Start of `cperl-beautify-regexp'. + +;;;; After 1.32.4 +;;; `cperl-tags-hier-init' did not work in text-mode. +;;; `cperl-noscan-files-regexp' had a misprint. +;;; Generation of Class Hierarchy was broken due to a bug in `x-popup-menu' +;;; in 19.34. + +;;;; After 1.33: +;;; my,local highlight vars after {} too. +;;; TAGS could not be created before imenu was loaded. +;;; `cperl-indent-left-aligned-comments' created. +;;; Logic of `cperl-indent-exp' changed a little bit, should be more +;;; robust w.r.t. multiline strings. +;;; Recognition of blah'foo takes into account strings. +;;; Added '.al' to the list of Perl extensions. +;;; Class hierarchy is "mostly" sorted (need to rethink algorthm +;;; of pruning one-root-branch subtrees to get yet better sorting.) +;;; Regeneration of TAGS was busted. +;;; Can use `syntax-table' property when generating TAGS +;;; (governed by `cperl-use-syntax-table-text-property-for-tags'). + +;;;; After 1.35: +;;; Can process several =pod/=cut sections one after another. +;;; Knows of `extproc' when under `emx', indents with `__END__' and `__DATA__'. +;;; `cperl-under-as-char' implemented (XEmacs people like broken behaviour). +;;; Beautifier for regexps fixed. +;;; `cperl-beautify-level', `cperl-contract-level' coded +;;; +;;;; Emacs's 20.2 problems: +;;; `imenu.el' has bugs, `imenu-add-to-menubar' does not work. +;;; Couple of others problems with 20.2 were reported, my ability to check/fix +;;; them is very reduced now. + +;;;; After 1.36: +;;; 'C-M-|' in XEmacs fixed + +;;;; After 1.37: +;;; &&s was not recognized as start of regular expression; +;;; Will "preprocess" the contents of //e part of s///e too; +;;; What to do with s# blah # foo #e ? +;;; Should handle s;blah;foo;; better. +;;; Now the only known problems with regular expression recognition: +;;;;;;; s/bar/ - different delimiters (end ignored) +;;;;;;; s/foo/\\bar/ - backslash at start of subst (made into one chunk) +;;;;;;; s/foo// - empty subst (made into one chunk + '/') +;;;;;;; s/foo/(bar)/ - start-group at start of subst (internal group will not match backwards) + +;;;; After 1.38: +;;; We highlight closing / of s/blah/foo/e; +;;; This handles s# blah # foo #e too; +;;; s//blah/, s///, s/blah// works again, and s#blah## too, the algorithm +;;; is much simpler now; +;;; Next round of changes: s\\\ works, s/foo/, +;;; comments between the first and the second part allowed +;;; Another problem discovered: +;;;;;;; s[foo] e - e part delimited by different <> (will not match) +;;; `cperl-find-pods-heres' somehow maybe called when string-face is undefined +;;; - put a stupid workaround for 20.1 + +;;;; After 1.39: +;;; Could indent here-docs for comments; +;;; These problems fixed: +;;;;;;; s/foo/\\bar/ - backslash at start of subst (made into two chunk) +;;;;;;; s[foo] e - "e" part delimited by "different" <> (will match) +;;; Matching brackets honor prefices, may expand abbreviations; +;;; When expanding abbrevs, will remove last char only after +;;; self-inserted whitespace; +;;; More convenient "Refress hard constructs" in menu; +;;; `cperl-add-tags-recurse', `cperl-add-tags-recurse-noxs' +;;; added (for -batch mode); +;;; Better handling of errors when scanning for Perl constructs; +;;;;;;; Possible "problem" with class hierarchy in Perl distribution +;;;;;;; directory: ./ext duplicates ./lib; +;;; Write relative paths for generated TAGS; + +;;;; After 1.40: +;;; s /// may be separated by "\n\f" too; +;;; `s #blah' recognized as a comment; +;;; Would highlight s/abc//s wrong; +;;; Debugging code in `cperl-electric-keywords' was leaking a message; + +;;;; After 1.41: +;;; RMS changes for 20.3 merged + +;;;; 2.0.1.0: RMS mode (has 3 misprints) + +;;;; After 2.0: +;;; RMS whitespace changes for 20.3 merged + +;;;; After 2.1: +;;; History updated + +;;;; After 2.2: +;;; Merge `c-style-alist' since `c-mode' is no more. (Somebody who +;;; uses the styles should check that they work OK!) +;;; All the variable warnings go away, some undef functions too. + +;;;; After 2.3: +;;; Added `cperl-perldoc' (thanks to Anthony Foiani ) +;;; Added `cperl-pod-to-manpage' (thanks to Nick Roberts ) +;;; All the function warnings go away. + +;;;; After 2.4: +;;; `Perl doc', `Regexp' submenus created (latter to allow short displays). +;;; `cperl-clobber-lisp-bindings' added. +;;; $a->y() is not y///. +;;; `cperl-after-block-p' was missing a `save-excursion' => wrong results. +;;; `cperl-val' was defined too late. +;;; `cperl-init-faces' was failing. +;;; Init faces when loading `ps-print'. + +;;;; After 2.4: +;;; `cperl-toggle-autohelp' implemented. +;;; `while SPACE LESS' was buggy. +;;; `-text' in `[-text => 1]' was not highlighted. +;;; `cperl-after-block-p' was FALSE after `sub f {}'. + +;;;; After 2.5: +;;; `foreachmy', `formy' expanded too. +;;; Expand `=pod-directive'. +;;; `cperl-linefeed' behaves reasonable in POD-directive lines. +;;; `cperl-electric-keyword' prints a message, governed by +;;; `cperl-message-electric-keyword'. + +;;;; After 2.6: +;;; Typing `}' was not checking for being block or not. +;;; Beautifying levels in RE: Did not know about lookbehind; +;;; finding *which* level was not intuitive; +;;; `cperl-beautify-levels' added. +;;; Allow here-docs contain `=head1' and friends (at least for keywords). + +;;;; After 2.7: +;;; Fix for broken `font-lock-unfontify-region-function'. Should +;;; preserve `syntax-table' properties even with `lazy-lock'. + +;;;; After 2.8: +;;; Some more compile time warnings crept in. +;;; `cperl-indent-region-fix-else' implemented. +;;; `cperl-fix-line-spacing' implemented. +;;; `cperl-invert-if-unless' implemented (C-c C-t and in Menu). +;;; Upgraded hints to mention 20.2's goods/bads. +;;; Started to use `cperl-extra-newline-before-brace-multiline', +;;; `cperl-break-one-line-blocks-when-indent', +;;; `cperl-fix-hanging-brace-when-indent', `cperl-merge-trailing-else'. + +;;;; After 2.9: +;;; Workaround for another `font-lock's `syntax-table' text-property bug. +;;; `zerop' could be applied to nil. +;;; At last, may work with `font-lock' without setting `cperl-font-lock'. +;;; (We expect that starting from 19.33, `font-lock' supports keywords +;;; being a function - what is a correct version?) +;;; Rename `cperl-indent-region-fix-else' to +;;; `cperl-indent-region-fix-constructs'. +;;; `cperl-fix-line-spacing' could be triggered inside strings, would not +;;; know what to do with BLOCKs of map/printf/etc. +;;; `cperl-merge-trailing-else' and `cperl-fix-line-spacing' handle +;;; `continue' too. +;;; Indentation after {BLOCK} knows about map/printf/etc. +;;; Finally: treat after-comma lines as continuation lines. + +;;;; After 2.10: +;;; `continue' made electric. +;;; Electric `do' inserts `do/while'. +;;; Some extra compile-time warnings crept in. +;;; `font-lock' of 19.33 could not handle font-lock-keywords being a function +;;; returning a symbol. + +;;;; After 2.11: +;;; Changes to make syntaxification to be autoredone via `font-lock'. +;;; Switched on by `cperl-syntaxify-by-font-lock', off by default so far. + +;;;; After 2.12: +;;; Remove some commented out chunks. +;;; Styles are slightly updated (a lot of work is needed, especially +;;; with new `cperl-fix-line-spacing'). + +;;;; After 2.13: +;;; Old value of style is memorized when choosing a new style, may be +;;; restored from the same menu. +;;; Mode-documentation added to micro-docs. +;;; `cperl-praise' updated. +;;; `cperl-toggle-construct-fix' added on C-c C-w and menu. +;;; `auto-fill-mode' added on C-c C-f and menu. +;;; `PerlStyle' style added. +;;; Message for termination of scan corrected. + +;;;; After 2.14: + +;;; Did not work with -q + +;;;; After 2.15: + +;;; `cperl-speed' hints added. +;;; Minor style fixes. + +;;;; After 2.15: +;;; Make backspace electric after expansion of `else/continue' too. + +;;;; After 2.16: +;;; Starting to merge changes to RMS emacs version. + +;;;; After 2.17: +;;; Merged custom stuff and darn `font-lock-constant-face'. + +;;;; After 2.18: +;;; Bumped the version to 3.1 + +;;;; After 3.1: +;;; Fixed customization to honor cperl-hairy. +;;; Created customization groups. Sent to RMS to include into 2.3. + +;;;; After 3.2: +;;; Interaction of `font-lock-hot-pass' and `cperl-syntaxify-by-font-lock'. +;;; (`cperl-after-block-and-statement-beg'): +;;; (`cperl-after-block-p'): +;;; (`cperl-after-expr-p'): It is BLOCK if we reach lim when backup sexp. +;;; (`cperl-indent-region'): Make a marker for END - text added/removed. +;;; (`cperl-style-alist', `cperl-styles-entries') +;;; Include `cperl-merge-trailing-else' where the value is clear. + +;;;; After 3.3: +;;; (`cperl-tips'): +;;; (`cperl-problems'): Improvements to docs. + +;;;; After 3.4: +;;; (`cperl-mode'): Make lazy syntaxification possible. +;;; (`cperl-find-pods-heres'): Safe a position in buffer where it is safe to +;;; restart syntaxification. +;;; (`cperl-syntaxify-by-font-lock'): Set to t, should be safe now. + +;;;; After 3.5: +;;; (`cperl-syntaxify-by-font-lock'): Better default, customizes to +;;; `message' too. + +;;;; After 3.6: +;;; (`cperl-find-pods-heres'): changed so that -d ?foo? is a RE. +;;; (`cperl-array-face'): changed name from `font-lock-emphasized-face'. +;;; (`cperl-hash-face'): changed name from `font-lock-other-emphasized-face'. +;;; Use `defface' to define these two extra faces. + +;;;; After 3.7: +;;; Can use linear algorithm for indentation if Emacs supports it: +;;; indenting DB::DB (800+ lines) improved from 69 sec to 11 sec +;;; (73 vs 15 with imenu). +;;; (`cperl-emacs-can-parse'): New state. +;;; (`cperl-indent-line'): Corrected to use global state. +;;; (`cperl-calculate-indent'): Likewise. +;;; (`cperl-fix-line-spacing'): Likewise (not used yet). + +;;;; After 3.8: +;;; (`cperl-choose-color'): Converted to a function (to be compilable in text-mode). + +;;;; After 3.9: +;;; (`cperl-dark-background '): Disable without window-system. + +;;;; After 3.10: +;;; Do `defface' only if window-system. + +;;;; After 3.11: +;;; (`cperl-fix-line-spacing'): sped up to bail out early. +;;; (`cperl-indent-region'): Disable hooks during the call (how to call them later?). + +;;; Now indents 820-line-long function in 6.5 sec (including syntaxification) the first time +;;; (when buffer has few properties), 7.1 sec the second time. + +;;;Function Name Call Count Elapsed Time Average Time +;;;========================================= ========== ============ ============ +;;;cperl-indent-exp 1 10.039999999 10.039999999 +;;;cperl-indent-region 1 10.0 10.0 +;;;cperl-indent-line 821 6.2100000000 0.0075639464 +;;;cperl-calculate-indent 821 5.0199999999 0.0061144945 +;;;cperl-backward-to-noncomment 2856 2.0500000000 0.0007177871 +;;;cperl-fontify-syntaxically 2 1.78 0.8900000000 +;;;cperl-find-pods-heres 2 1.78 0.8900000000 +;;;cperl-update-syntaxification 1 1.78 1.78 +;;;cperl-fix-line-spacing 769 1.4800000000 0.0019245773 +;;;cperl-after-block-and-statement-beg 163 1.4100000000 0.0086503067 +;;;cperl-block-p 775 1.1800000000 0.0015225806 +;;;cperl-to-comment-or-eol 3652 1.1200000000 0.0003066812 +;;;cperl-after-block-p 165 1.0500000000 0.0063636363 +;;;cperl-commentify 141 0.22 0.0015602836 +;;;cperl-get-state 813 0.16 0.0001968019 +;;;cperl-backward-to-start-of-continued-exp 26 0.12 0.0046153846 +;;;cperl-delay-update-hook 2107 0.0899999999 4.271...e-05 +;;;cperl-protect-defun-start 141 0.0700000000 0.0004964539 +;;;cperl-after-label 407 0.0599999999 0.0001474201 +;;;cperl-forward-re 139 0.0299999999 0.0002158273 +;;;cperl-comment-indent 26 0.0299999999 0.0011538461 +;;;cperl-use-region-p 8 0.0 0.0 +;;;cperl-lazy-hook 15 0.0 0.0 +;;;cperl-after-expr-p 8 0.0 0.0 +;;;cperl-font-lock-unfontify-region-function 1 0.0 0.0 + +;;;Function Name Call Count Elapsed Time Average Time +;;;========================================= ========== ============ ============ +;;;cperl-fix-line-spacing 769 1.4500000000 0.0018855656 +;;;cperl-indent-line 13 0.3100000000 0.0238461538 +;;;cperl-after-block-and-statement-beg 69 0.2700000000 0.0039130434 +;;;cperl-after-block-p 69 0.2099999999 0.0030434782 +;;;cperl-calculate-indent 13 0.1000000000 0.0076923076 +;;;cperl-backward-to-noncomment 177 0.0700000000 0.0003954802 +;;;cperl-get-state 13 0.0 0.0 +;;;cperl-to-comment-or-eol 179 0.0 0.0 +;;;cperl-get-help-defer 1 0.0 0.0 +;;;cperl-lazy-hook 11 0.0 0.0 +;;;cperl-after-expr-p 2 0.0 0.0 +;;;cperl-block-p 13 0.0 0.0 +;;;cperl-after-label 5 0.0 0.0 + +;;;; After 3.12: +;;; (`cperl-find-pods-heres'): do not warn on `=cut' if doing a chunk only. + +;;;; After 3.13: +;;; (`cperl-mode'): load pseudo-faces on `cperl-find-pods-heres' (for 19.30). +;;; (`x-color-defined-p'): was not compiling on XEmacs +;;; (`cperl-find-pods-heres'): 1 << 6 was OK, but 1<<6 was considered as HERE +;;; made into a string. + +;;;; After 3.14: +;;; (`cperl-find-pods-heres'): Postpone addition of faces after syntactic step +;;; Recognition of was wrong. +;;; (`cperl-clobber-lisp-bindings'): if set, C-c variants are the old ones +;;; (`cperl-unwind-to-safe'): New function. +;;; (`cperl-fontify-syntaxically'): Use `cperl-unwind-to-safe' to start at reasonable position. + +;;;; After 3.15: +;;; (`cperl-forward-re'): Highlight the trailing / in s/foo// as string. +;;; Highlight the starting // in s//foo/ as function-name. + +;;;; After 3.16: +;;; (`cperl-find-pods-heres'): Highlight `gem' in s///gem as a keyword. + +;;;; After 4.0: +;;; (`cperl-find-pods-heres'): `qr' added +;;; (`cperl-electric-keyword'): Likewise +;;; (`cperl-electric-else'): Likewise +;;; (`cperl-to-comment-or-eol'): Likewise +;;; (`cperl-make-regexp-x'): Likewise +;;; (`cperl-init-faces'): Likewise, and `lock' (as overridable?). +;;; (`cperl-find-pods-heres'): Knows that split// is null-RE. +;;; Highlights separators in 3-parts expressions +;;; as labels. + +;;;; After 4.1: +;;; (`cperl-find-pods-heres'): <> was considered as a glob +;;; (`cperl-syntaxify-unwind'): New configuration variable +;;; (`cperl-fontify-m-as-s'): New configuration variable + +;;;; After 4.2: +;;; (`cperl-find-pods-heres'): of the last line being `=head1' fixed. + +;;; Handling of a long construct is still buggy if only the part of +;;; construct touches the updated region (we unwind to the start of +;;; long construct, but the end may have residual properties). + +;;; (`cperl-unwind-to-safe'): would not go to beginning of buffer. +;;; (`cperl-electric-pod'): check for after-expr was performed +;;; inside of POD too. + +;;;; After 4.3: +;;; (`cperl-backward-to-noncomment'): better treatment of PODs and HEREs. + +;;; Indent-line works good, but indent-region does not - at toplevel... +;;; (`cperl-unwind-to-safe'): Signature changed. +;;; (`x-color-defined-p'): was defmacro'ed with a tick. Remove another def. +;;; (`cperl-clobber-mode-lists'): New configuration variable. +;;; (`cperl-array-face'): One of definitions was garbled. + +;;;; After 4.4: +;;; (`cperl-not-bad-style-regexp'): Updated. +;;; (`cperl-make-regexp-x'): Misprint in a message. +;;; (`cperl-find-pods-heres'): $a-1 ? foo : bar; was a regexp. +;;; `<< (' was considered a start of POD. +;;; Init: `cperl-is-face' was busted. +;;; (`cperl-make-face'): New macros. +;;; (`cperl-force-face'): New macros. +;;; (`cperl-init-faces'): Corrected to use new macros; +;;; `if' for copying `reference-face' to +;;; `constant-face' was backward. +;;; (`font-lock-other-type-face'): Done via `defface' too. + +;;;; After 4.5: +;;; (`cperl-init-faces-weak'): use `cperl-force-face'. +;;; (`cperl-after-block-p'): After END/BEGIN we are a block. +;;; (`cperl-mode'): `font-lock-unfontify-region-function' +;;; was set to a wrong function. +;;; (`cperl-comment-indent'): Commenting __END__ was not working. +;;; (`cperl-indent-for-comment'): Likewise. +;;; (Indenting is still misbehaving at toplevel.) + +;;;; After 4.5: +;;; (`cperl-unwind-to-safe'): Signature changed, unwinds end too. +;;; (`cperl-find-pods-heres'): mark qq[]-etc sections as syntax-type=string +;;; (`cperl-fontify-syntaxically'): Unwinds start and end to go out of +;;; long strings (not very successful). + +;;; >>>> CPerl should be usable in write mode too now <<<< + +;;; (`cperl-syntaxify-by-font-lock'): Better default - off in text-mode. +;;; (`cperl-tips'): Updated docs. +;;; (`cperl-problems'): Updated docs. + +;;;; After 4.6: +;;; (`cperl-calculate-indent'): Did not consider `,' as continuation mark for statements. +;;; (`cperl-write-tags'): Correct for XEmacs's `visit-tags-table-buffer'. + +;;;; After 4.7: +;;; (`cperl-calculate-indent'): Avoid parse-data optimization at toplevel. +;;; Should indent correctly at toplevel too. +;;; (`cperl-tags-hier-init'): Gross hack to pretend we work (are we?). +;;; (`cperl-find-pods-heres'): Was not processing sub protos after a comment ine. +;;; Was treating $a++ <= 5 as a glob. + +;;;; After 4.8: +;;; (toplevel): require custom unprotected => failure on 19.28. +;;; (`cperl-xemacs-p') defined when compile too +;;; (`cperl-tags-hier-init'): Another try to work around XEmacs problems +;;; Better progress messages. +;;; (`cperl-find-tags'): Was writing line/pos in a wrong order, +;;; pos off by 1 and not at beg-of-line. +;;; (`cperl-etags-snarf-tag'): New macro +;;; (`cperl-etags-goto-tag-location'): New macro +;;; (`cperl-write-tags'): When removing old TAGS info was not +;;; relativizing filename + +;;;; After 4.9: +;;; (`cperl-version'): New variable. New menu entry + +;;;; After 4.10: +;;; (`cperl-tips'): Updated. +;;; (`cperl-non-problems'): Updated. +;;; random: References to future 20.3 removed. + +;;;; After 4.11: +;;; (`perl-font-lock-keywords'): Would not highlight `sub foo($$);'. +;;; Docstrings: Menu was described as `CPerl' instead of `Perl' + +;;;; After 4.12: +;;; (`cperl-toggle-construct-fix'): Was toggling to t instead of 1. +;;; (`cperl-ps-print-init'): Associate `cperl-array-face', `cperl-hash-face' +;;; remove `font-lock-emphasized-face'. +;;; remove `font-lock-other-emphasized-face'. +;;; remove `font-lock-reference-face'. +;;; remove `font-lock-keyword-face'. +;;; Use `eval-after-load'. +;;; (`cperl-init-faces'): remove init `font-lock-other-emphasized-face'. +;;; remove init `font-lock-emphasized-face'. +;;; remove init `font-lock-keyword-face'. +;;; (`cperl-tips-faces'): New variable and an entry into Mini-docs. +;;; (`cperl-indent-region'): Do not indent whitespace lines +;;; (`cperl-indent-exp'): Was not processing else-blocks. +;;; (`cperl-calculate-indent'): Remove another parse-data optimization +;;; at toplevel: would indent correctly. +;;; (`cperl-get-state'): NOP line removed. + +;;;; After 4.13: +;;; (`cperl-ps-print-init'): Remove not-CPerl-related faces. +;;; (`cperl-ps-print'): New function and menu entry. +;;; (`cperl-ps-print-face-properties'): New configuration variable. +;;; (`cperl-invalid-face'): New configuration variable. +;;; (`cperl-nonoverridable-face'): New face. Renamed from +;;; `font-lock-other-type-face'. +;;; (`perl-font-lock-keywords'): Highlight trailing whitespace +;;; (`cperl-contract-levels'): Documentation corrected. +;;; (`cperl-contract-level'): Likewise. + +;;;; After 4.14: +;;; (`cperl-ps-print'): `ps-print-face-extension-alist' was not in old Emaxen, +;;; same with `ps-extend-face-list' +;;; (`cperl-ps-extend-face-list'): New macro. + +;;;; After 4.15: +;;; (`cperl-init-faces'): Interpolate `cperl-invalid-face'. +;;; (`cperl-forward-re'): Emit a meaningful error instead of a cryptic +;;; one for uncomplete REx near end-of-buffer. +;;; (`cperl-find-pods-heres'): Tolerate unfinished REx at end-of-buffer. + +;;;; After 4.16: +;;; (`cperl-find-pods-heres'): `unwind-protect' was left commented. + +;;;; After 4.17: +;;; (`cperl-invalid-face'): Change to ''underline. + +;;;; After 4.18: +;;; (`cperl-find-pods-heres'): / and ? after : start a REx. +;;; (`cperl-after-expr-p'): Skip labels when checking +;;; (`cperl-calculate-indent'): Correct for labels when calculating +;;; indentation of continuations. +;;; Docstring updated. + +;;;; After 4.19: +;;; Minor (mostly spelling) corrections from 20.3.3 merged. + +;;;; After 4.20: +;;; (`cperl-tips'): Another workaround added. Sent to RMS for 20.4. + +;;;; After 4.21: +;;; (`cperl-praise'): Mention linear-time indent. +;;; (`cperl-find-pods-heres'): @if ? a : b was considered a REx. + +;;;; After 4.22: +;;; (`cperl-after-expr-p'): Make true after __END__. +;;; (`cperl-electric-pod'): "SYNOPSIS" was misspelled. + +;;;; After 4.23: +;;; (`cperl-beautify-regexp-piece'): Was not allowing for *? after a class. +;;; Allow for POSIX char-classes. +;;; Remove trailing whitespace when +;;; adding new linebreak. +;;; Add a level counter to stop shallow. +;;; Indents unprocessed groups rigidly. +;;; (`cperl-beautify-regexp'): Add an optional count argument to go that +;;; many levels deep. +;;; (`cperl-beautify-level'): Likewise +;;; Menu: Add new entries to Regexp menu to do one level +;;; (`cperl-contract-level'): Was entering an infinite loop +;;; (`cperl-find-pods-heres'): Typo (double quoting). +;;; Was detecting < $file > as FH instead of glob. +;;; Support for comments in RExen (except +;;; for m#\#comment#x), governed by +;;; `cperl-regexp-scan'. +;;; (`cperl-regexp-scan'): New customization variable. +;;; (`cperl-forward-re'): Improve logic of resetting syntax table. + +;;;; After 4.23 and: After 4.24: +;;; (`cperl-contract-levels'): Restore position. +;;; (`cperl-beautify-level'): Likewise. +;;; (`cperl-beautify-regexp'): Likewise. +;;; (`cperl-commentify'): Rudimental support for length=1 runs +;;; (`cperl-find-pods-heres'): Process 1-char long REx comments too /a#/x +;;; Processes REx-comments in #-delimited RExen. +;;; MAJOR BUG CORRECTED: after a misparse +;;; a body of a subroutine could be corrupted!!! +;;; One might need to reeval the function body +;;; to fix things. (A similar bug was +;;; present in `cperl-indent-region' eons ago.) +;;; To reproduce: +;; (defun foo () (let ((a '(t))) (insert (format "%s" a)) (setcar a 'BUG) t)) +;; (foo) +;; (foo) +;;; C-x C-e the above three lines (at end-of-line). First evaluation +;;; of `foo' inserts (t), second one inserts (BUG) ?! +;;; +;;; In CPerl it was triggered by inserting then deleting `/' at start of +;;; / a (?# asdf {[(}asdf )ef,/; + +;;;; After 4.25: +;;; (`cperl-commentify'): Was recognizing length=2 "strings" as length=1. +;;; (`imenu-example--create-perl-index'): +;;; Was not enforcing syntaxification-to-the-end. +;;; (`cperl-invert-if-unless'): Allow `for', `foreach'. +;;; (`cperl-find-pods-heres'): Quote `cperl-nonoverridable-face'. +;;; Mark qw(), m()x as indentable. +;;; (`cperl-init-faces'): Highlight `sysopen' too. +;;; Highlight $var in `for my $var' too. +;;; (`cperl-invert-if-unless'): Was leaving whitespace at end. +;;; (`cperl-linefeed'): Was splitting $var{$foo} if point after `{'. +;;; (`cperl-calculate-indent'): Remove old commented out code. +;;; Support (primitive) indentation of qw(), m()x. + + +;;;; After 4.26: +;;; (`cperl-problems'): Mention `fill-paragraph' on comment. \"" and +;;; q [] with intervening newlines. +;;; (`cperl-autoindent-on-semi'): New customization variable. +;;; (`cperl-electric-semi'): Use `cperl-autoindent-on-semi'. +;;; (`cperl-tips'): Mention how to make CPerl the default mode. +;;; (`cperl-mode'): Support `outline-minor-mode' +;;; (Thanks to Mark A. Hershberger). +;;; (`cperl-outline-level'): New function. +;;; (`cperl-highlight-variables-indiscriminately'): New customization var. +;;; (`cperl-init-faces'): Use `cperl-highlight-variables-indiscriminately'. +;;; (Thanks to Sean Kamath ). +;;; (`cperl-after-block-p'): Support CHECK and INIT. +;;; (`cperl-init-faces'): Likewise and "our". +;;; (Thanks to Doug MacEachern ). +;;; (`cperl-short-docs'): Likewise and "our". + + +;;;; After 4.27: +;;; (`cperl-find-pods-heres'): Recognize \"" as a string. +;;; Mark whitespace and comments between q and [] +;;; as `syntax-type' => `prestring'. +;;; Allow whitespace between << and "FOO". +;;; (`cperl-problems'): Remove \"" and q [] with intervening newlines. +;;; Mention multiple < t. +;;; Do not recognize $opt_s and $opt::s as s///. +;;; (`cperl-perldoc'): Use case-sensitive search (contributed). +;;; (`cperl-fix-line-spacing'): Allow "_" in $vars of foreach etc. when +;;; underscore isn't a word char (gdj-contributed). +;;; (`defun-prompt-regexp'): Allow prototypes. +;;; (`cperl-vc-header-alist'): Extract numeric version from the Id. +;;; Toplevel: Put toggle-autohelp into the mode menu. +;;; Better docs for toggle/set/unset autohelp. +;;; (`cperl-electric-backspace-untabify'): New customization variable +;;; (`cperl-after-expr-p'): Works after here-docs, formats, and PODs too +;;; (affects many electric constructs). +;;; (`cperl-calculate-indent'): Takes into account `first-format-line' ==> +;;; works after format. +;;; (`cperl-short-docs'): Make it work with ... too. +;;; "array context" ==> "list context" +;;; (`cperl-electric-keyword'): make $if (etc: "$@%&*") non-electric +;;; '(' after keyword would insert a doubled paren +;;; (`cperl-electric-paren'): documented affected by `cperl-electric-parens' +;;; (`cperl-electric-rparen'): Likewise +;;; (`cperl-build-manpage'): New function by Nick Roberts +;;; (`cperl-perldoc'): Make it work in XEmacs too + +;;;; After 4.36: +;;; (`cperl-find-pods-heres'): Recognize s => 1 and {s} (as a key or varname), +;;; { s:: } and { s::bar::baz } as varnames. +;;; (`cperl-after-expr-p'): Updates syntaxification before checks +;;; (`cperl-calculate-indent'): Likewise +;;; Fix wrong indent of blocks starting with POD +;;; (`cperl-after-block-p'): Optional argument for checking for a pre-block +;;; Recognize `continue' blocks too. +;;; (`cperl-electric-brace'): use `cperl-after-block-p' for detection; +;;; Now works for else/continue/sub blocks +;;; (`cperl-short-docs'): Minor edits; make messages fit 80-column screen + +;;; Code: + + +(if (fboundp 'eval-when-compile) + (eval-when-compile + (condition-case nil + (require 'custom) + (error nil)) + (condition-case nil + (require 'man) + (error nil)) + (defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version)) + (defvar cperl-can-font-lock + (or cperl-xemacs-p + (and (boundp 'emacs-major-version) + (or window-system + (> emacs-major-version 20))))) + (if cperl-can-font-lock + (require 'font-lock)) + (defvar msb-menu-cond) + (defvar gud-perldb-history) + (defvar font-lock-background-mode) ; not in Emacs + (defvar font-lock-display-type) ; ditto + (or (fboundp 'defgroup) + (defmacro defgroup (name val doc &rest arr) + nil)) + (or (fboundp 'custom-declare-variable) + (defmacro defcustom (name val doc &rest arr) + (` (defvar (, name) (, val) (, doc))))) + (or (and (fboundp 'custom-declare-variable) + (string< "19.31" emacs-version)) ; Checked with 19.30: defface does not work + (defmacro defface (&rest arr) + nil)) + ;; Avoid warning (tmp definitions) + (or (fboundp 'x-color-defined-p) + (defmacro x-color-defined-p (col) + (cond ((fboundp 'color-defined-p) (` (color-defined-p (, col)))) + ;; XEmacs >= 19.12 + ((fboundp 'valid-color-name-p) (` (valid-color-name-p (, col)))) + ;; XEmacs 19.11 + ((fboundp 'x-valid-color-name-p) (` (x-valid-color-name-p (, col)))) + (t '(error "Cannot implement color-defined-p"))))) + (defmacro cperl-is-face (arg) ; Takes quoted arg + (cond ((fboundp 'find-face) + (` (find-face (, arg)))) + (;;(and (fboundp 'face-list) + ;; (face-list)) + (fboundp 'face-list) + (` (member (, arg) (and (fboundp 'face-list) + (face-list))))) + (t + (` (boundp (, arg)))))) + (defmacro cperl-make-face (arg descr) ; Takes unquoted arg + (cond ((fboundp 'make-face) + (` (make-face (quote (, arg))))) + (t + (` (defvar (, arg) (quote (, arg)) (, descr)))))) + (defmacro cperl-force-face (arg descr) ; Takes unquoted arg + (` (progn + (or (cperl-is-face (quote (, arg))) + (cperl-make-face (, arg) (, descr))) + (or (boundp (quote (, arg))) ; We use unquoted variants too + (defvar (, arg) (quote (, arg)) (, descr)))))) + (if cperl-xemacs-p + (defmacro cperl-etags-snarf-tag (file line) + (` (progn + (beginning-of-line 2) + (list (, file) (, line))))) + (defmacro cperl-etags-snarf-tag (file line) + (` (etags-snarf-tag)))) + (if cperl-xemacs-p + (defmacro cperl-etags-goto-tag-location (elt) + (`;;(progn + ;; (switch-to-buffer (get-file-buffer (elt (, elt) 0))) + ;; (set-buffer (get-file-buffer (elt (, elt) 0))) + ;; Probably will not work due to some save-excursion??? + ;; Or save-file-position? + ;; (message "Did I get to line %s?" (elt (, elt) 1)) + (goto-line (string-to-int (elt (, elt) 1))))) + ;;) + (defmacro cperl-etags-goto-tag-location (elt) + (` (etags-goto-tag-location (, elt))))))) + +(defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version)) + +(defvar cperl-can-font-lock + (or cperl-xemacs-p + (and (boundp 'emacs-major-version) + (or window-system + (> emacs-major-version 20))))) + +(condition-case nil + (require 'custom) + (error nil)) ; Already fixed by eval-when-compile + +(defun cperl-choose-color (&rest list) + (let (answer) + (while list + (or answer + (if (or (x-color-defined-p (car list)) + (null (cdr list))) + (setq answer (car list)))) + (setq list (cdr list))) + answer)) + + +(defgroup cperl nil + "Major mode for editing Perl code." + :prefix "cperl-" + :group 'languages) + +(defgroup cperl-indentation-details nil + "Indentation." + :prefix "cperl-" + :group 'cperl) + +(defgroup cperl-affected-by-hairy nil + "Variables affected by `cperl-hairy'." + :prefix "cperl-" + :group 'cperl) + +(defgroup cperl-autoinsert-details nil + "Auto-insert tuneup." + :prefix "cperl-" + :group 'cperl) + +(defgroup cperl-faces nil + "Fontification colors." + :prefix "cperl-" + :group 'cperl) + +(defgroup cperl-speed nil + "Speed vs. validity tuneup." + :prefix "cperl-" + :group 'cperl) + +(defgroup cperl-help-system nil + "Help system tuneup." + :prefix "cperl-" + :group 'cperl) + + +(defcustom cperl-extra-newline-before-brace nil + "*Non-nil means that if, elsif, while, until, else, for, foreach +and do constructs look like: + + if () + { + } + +instead of: + + if () { + }" + :type 'boolean + :group 'cperl-autoinsert-details) + +(defcustom cperl-extra-newline-before-brace-multiline + cperl-extra-newline-before-brace + "*Non-nil means the same as `cperl-extra-newline-before-brace', but +for constructs with multiline if/unless/while/until/for/foreach condition." + :type 'boolean + :group 'cperl-autoinsert-details) + +(defcustom cperl-indent-level 2 + "*Indentation of CPerl statements with respect to containing block." + :type 'integer + :group 'cperl-indentation-details) + +(defcustom cperl-lineup-step nil + "*`cperl-lineup' will always lineup at multiple of this number. +If nil, the value of `cperl-indent-level' will be used." + :type '(choice (const nil) integer) + :group 'cperl-indentation-details) + +(defcustom cperl-brace-imaginary-offset 0 + "*Imagined indentation of a Perl open brace that actually follows a statement. +An open brace following other text is treated as if it were this far +to the right of the start of its line." + :type 'integer + :group 'cperl-indentation-details) + +(defcustom cperl-brace-offset 0 + "*Extra indentation for braces, compared with other text in same context." + :type 'integer + :group 'cperl-indentation-details) +(defcustom cperl-label-offset -2 + "*Offset of CPerl label lines relative to usual indentation." + :type 'integer + :group 'cperl-indentation-details) +(defcustom cperl-min-label-indent 1 + "*Minimal offset of CPerl label lines." + :type 'integer + :group 'cperl-indentation-details) +(defcustom cperl-continued-statement-offset 2 + "*Extra indent for lines not starting new statements." + :type 'integer + :group 'cperl-indentation-details) +(defcustom cperl-continued-brace-offset 0 + "*Extra indent for substatements that start with open-braces. +This is in addition to cperl-continued-statement-offset." + :type 'integer + :group 'cperl-indentation-details) +(defcustom cperl-close-paren-offset -1 + "*Extra indent for substatements that start with close-parenthesis." + :type 'integer + :group 'cperl-indentation-details) + +(defcustom cperl-auto-newline nil + "*Non-nil means automatically newline before and after braces, +and after colons and semicolons, inserted in CPerl code. The following +\\[cperl-electric-backspace] will remove the inserted whitespace. +Insertion after colons requires both this variable and +`cperl-auto-newline-after-colon' set." + :type 'boolean + :group 'cperl-autoinsert-details) + +(defcustom cperl-autoindent-on-semi nil + "*Non-nil means automatically indent after insertion of (semi)colon. +Active if `cperl-auto-newline' is false." + :type 'boolean + :group 'cperl-autoinsert-details) + +(defcustom cperl-auto-newline-after-colon nil + "*Non-nil means automatically newline even after colons. +Subject to `cperl-auto-newline' setting." + :type 'boolean + :group 'cperl-autoinsert-details) + +(defcustom cperl-tab-always-indent t + "*Non-nil means TAB in CPerl mode should always reindent the current line, +regardless of where in the line point is when the TAB command is used." + :type 'boolean + :group 'cperl-indentation-details) + +(defcustom cperl-font-lock nil + "*Non-nil (and non-null) means CPerl buffers will use `font-lock-mode'. +Can be overwritten by `cperl-hairy' if nil." + :type '(choice (const null) boolean) + :group 'cperl-affected-by-hairy) + +(defcustom cperl-electric-lbrace-space nil + "*Non-nil (and non-null) means { after $ should be preceded by ` '. +Can be overwritten by `cperl-hairy' if nil." + :type '(choice (const null) boolean) + :group 'cperl-affected-by-hairy) + +(defcustom cperl-electric-parens-string "({[]})<" + "*String of parentheses that should be electric in CPerl. +Closing ones are electric only if the region is highlighted." + :type 'string + :group 'cperl-affected-by-hairy) + +(defcustom cperl-electric-parens nil + "*Non-nil (and non-null) means parentheses should be electric in CPerl. +Can be overwritten by `cperl-hairy' if nil." + :type '(choice (const null) boolean) + :group 'cperl-affected-by-hairy) + +(defvar zmacs-regions) ; Avoid warning + +(defcustom cperl-electric-parens-mark + (and window-system + (or (and (boundp 'transient-mark-mode) ; For Emacs + transient-mark-mode) + (and (boundp 'zmacs-regions) ; For XEmacs + zmacs-regions))) + "*Not-nil means that electric parens look for active mark. +Default is yes if there is visual feedback on mark." + :type 'boolean + :group 'cperl-autoinsert-details) + +(defcustom cperl-electric-linefeed nil + "*If true, LFD should be hairy in CPerl, otherwise C-c LFD is hairy. +In any case these two mean plain and hairy linefeeds together. +Can be overwritten by `cperl-hairy' if nil." + :type '(choice (const null) boolean) + :group 'cperl-affected-by-hairy) + +(defcustom cperl-electric-keywords nil + "*Not-nil (and non-null) means keywords are electric in CPerl. +Can be overwritten by `cperl-hairy' if nil." + :type '(choice (const null) boolean) + :group 'cperl-affected-by-hairy) + +(defcustom cperl-electric-backspace-untabify t + "*Not-nil means electric-backspace will untabify in CPerl." + :type 'boolean + :group 'cperl-autoinsert-details) + +(defcustom cperl-hairy nil + "*Not-nil means most of the bells and whistles are enabled in CPerl. +Affects: `cperl-font-lock', `cperl-electric-lbrace-space', +`cperl-electric-parens', `cperl-electric-linefeed', `cperl-electric-keywords', +`cperl-info-on-command-no-prompt', `cperl-clobber-lisp-bindings', +`cperl-lazy-help-time'." + :type 'boolean + :group 'cperl-affected-by-hairy) + +(defcustom cperl-comment-column 32 + "*Column to put comments in CPerl (use \\[cperl-indent] to lineup with code)." + :type 'integer + :group 'cperl-indentation-details) + +(defcustom cperl-vc-header-alist '((SCCS "($sccs) = ('%W\%' =~ /(\\d+(\\.\\d+)+)/) ;") + (RCS "($rcs) = (' $Id\$ ' =~ /(\\d+(\\.\\d+)+)/) ;")) + "*What to use as `vc-header-alist' in CPerl." + :type '(repeat (list symbol string)) + :group 'cperl) + +(defcustom cperl-clobber-mode-lists + (not + (and + (boundp 'interpreter-mode-alist) + (assoc "miniperl" interpreter-mode-alist) + (assoc "\\.\\([pP][Llm]\\|al\\)$" auto-mode-alist))) + "*Whether to install us into `interpreter-' and `extension' mode lists." + :type 'boolean + :group 'cperl) + +(defcustom cperl-info-on-command-no-prompt nil + "*Not-nil (and non-null) means not to prompt on C-h f. +The opposite behaviour is always available if prefixed with C-c. +Can be overwritten by `cperl-hairy' if nil." + :type '(choice (const null) boolean) + :group 'cperl-affected-by-hairy) + +(defcustom cperl-clobber-lisp-bindings nil + "*Not-nil (and non-null) means not overwrite C-h f. +The function is available on \\[cperl-info-on-command], \\[cperl-get-help]. +Can be overwritten by `cperl-hairy' if nil." + :type '(choice (const null) boolean) + :group 'cperl-affected-by-hairy) + +(defcustom cperl-lazy-help-time nil + "*Not-nil (and non-null) means to show lazy help after given idle time. +Can be overwritten by `cperl-hairy' to be 5 sec if nil." + :type '(choice (const null) (const nil) integer) + :group 'cperl-affected-by-hairy) + +(defcustom cperl-pod-face 'font-lock-comment-face + "*The result of evaluation of this expression is used for POD highlighting." + :type 'face + :group 'cperl-faces) + +(defcustom cperl-pod-head-face 'font-lock-variable-name-face + "*The result of evaluation of this expression is used for POD highlighting. +Font for POD headers." + :type 'face + :group 'cperl-faces) + +(defcustom cperl-here-face 'font-lock-string-face + "*The result of evaluation of this expression is used for here-docs highlighting." + :type 'face + :group 'cperl-faces) + +(defcustom cperl-invalid-face ''underline ; later evaluated by `font-lock' + "*The result of evaluation of this expression highlights trailing whitespace." + :type 'face + :group 'cperl-faces) + +(defcustom cperl-pod-here-fontify '(featurep 'font-lock) + "*Not-nil after evaluation means to highlight POD and here-docs sections." + :type 'boolean + :group 'cperl-faces) + +(defcustom cperl-fontify-m-as-s t + "*Not-nil means highlight 1arg regular expressions operators same as 2arg." + :type 'boolean + :group 'cperl-faces) + +(defcustom cperl-highlight-variables-indiscriminately nil + "*Non-nil means perform additional highlighting on variables. +Currently only changes how scalar variables are highlighted. +Note that that variable is only read at initialization time for +the variable `perl-font-lock-keywords-2', so changing it after you've +entered CPerl mode the first time will have no effect." + :type 'boolean + :group 'cperl) + +(defcustom cperl-pod-here-scan t + "*Not-nil means look for POD and here-docs sections during startup. +You can always make lookup from menu or using \\[cperl-find-pods-heres]." + :type 'boolean + :group 'cperl-speed) + +(defcustom cperl-regexp-scan t + "*Not-nil means make marking of regular expression more thorough. +Effective only with `cperl-pod-here-scan'. Not implemented yet." + :type 'boolean + :group 'cperl-speed) + +(defcustom cperl-imenu-addback nil + "*Not-nil means add backreferences to generated `imenu's. +May require patched `imenu' and `imenu-go'. Obsolete." + :type 'boolean + :group 'cperl-help-system) + +(defcustom cperl-max-help-size 66 + "*Non-nil means shrink-wrapping of info-buffer allowed up to these percents." + :type '(choice integer (const nil)) + :group 'cperl-help-system) + +(defcustom cperl-shrink-wrap-info-frame t + "*Non-nil means shrink-wrapping of info-buffer-frame allowed." + :type 'boolean + :group 'cperl-help-system) + +(defcustom cperl-info-page "perl" + "*Name of the info page containing perl docs. +Older version of this page was called `perl5', newer `perl'." + :type 'string + :group 'cperl-help-system) + +(defcustom cperl-use-syntax-table-text-property + (boundp 'parse-sexp-lookup-properties) + "*Non-nil means CPerl sets up and uses `syntax-table' text property." + :type 'boolean + :group 'cperl-speed) + +(defcustom cperl-use-syntax-table-text-property-for-tags + cperl-use-syntax-table-text-property + "*Non-nil means: set up and use `syntax-table' text property generating TAGS." + :type 'boolean + :group 'cperl-speed) + +(defcustom cperl-scan-files-regexp "\\.\\([pP][Llm]\\|xs\\)$" + "*Regexp to match files to scan when generating TAGS." + :type 'regexp + :group 'cperl) + +(defcustom cperl-noscan-files-regexp + "/\\(\\.\\.?\\|SCCS\\|RCS\\|CVS\\|blib\\)$" + "*Regexp to match files/dirs to skip when generating TAGS." + :type 'regexp + :group 'cperl) + +(defcustom cperl-regexp-indent-step nil + "*Indentation used when beautifying regexps. +If nil, the value of `cperl-indent-level' will be used." + :type '(choice integer (const nil)) + :group 'cperl-indentation-details) + +(defcustom cperl-indent-left-aligned-comments t + "*Non-nil means that the comment starting in leftmost column should indent." + :type 'boolean + :group 'cperl-indentation-details) + +(defcustom cperl-under-as-char t + "*Non-nil means that the _ (underline) should be treated as word char." + :type 'boolean + :group 'cperl) + +(defcustom cperl-extra-perl-args "" + "*Extra arguments to use when starting Perl. +Currently used with `cperl-check-syntax' only." + :type 'string + :group 'cperl) + +(defcustom cperl-message-electric-keyword t + "*Non-nil means that the `cperl-electric-keyword' prints a help message." + :type 'boolean + :group 'cperl-help-system) + +(defcustom cperl-indent-region-fix-constructs 1 + "*Amount of space to insert between `}' and `else' or `elsif' +in `cperl-indent-region'. Set to nil to leave as is. Values other +than 1 and nil will probably not work." + :type '(choice (const nil) (const 1)) + :group 'cperl-indentation-details) + +(defcustom cperl-break-one-line-blocks-when-indent t + "*Non-nil means that one-line if/unless/while/until/for/foreach BLOCKs +need to be reformatted into multiline ones when indenting a region." + :type 'boolean + :group 'cperl-indentation-details) + +(defcustom cperl-fix-hanging-brace-when-indent t + "*Non-nil means that BLOCK-end `}' may be put on a separate line +when indenting a region. +Braces followed by else/elsif/while/until are excepted." + :type 'boolean + :group 'cperl-indentation-details) + +(defcustom cperl-merge-trailing-else t + "*Non-nil means that BLOCK-end `}' followed by else/elsif/continue +may be merged to be on the same line when indenting a region." + :type 'boolean + :group 'cperl-indentation-details) + +(defcustom cperl-indent-parens-as-block nil + "*Non-nil means that non-block ()-, {}- and []-groups are indented as blocks, +but for trailing \",\" inside the group, which won't increase indentation. +One should tune up `cperl-close-paren-offset' as well." + :type 'boolean + :group 'cperl-indentation-details) + +(defcustom cperl-syntaxify-by-font-lock + (and cperl-can-font-lock + (boundp 'parse-sexp-lookup-properties)) + "*Non-nil means that CPerl uses `font-lock's routines for syntaxification." + :type '(choice (const message) boolean) + :group 'cperl-speed) + +(defcustom cperl-syntaxify-unwind + t + "*Non-nil means that CPerl unwinds to a start of a long construction +when syntaxifying a chunk of buffer." + :type 'boolean + :group 'cperl-speed) + +(defcustom cperl-ps-print-face-properties + '((font-lock-keyword-face nil nil bold shadow) + (font-lock-variable-name-face nil nil bold) + (font-lock-function-name-face nil nil bold italic box) + (font-lock-constant-face nil "LightGray" bold) + (cperl-array-face nil "LightGray" bold underline) + (cperl-hash-face nil "LightGray" bold italic underline) + (font-lock-comment-face nil "LightGray" italic) + (font-lock-string-face nil nil italic underline) + (cperl-nonoverridable-face nil nil italic underline) + (font-lock-type-face nil nil underline) + (underline nil "LightGray" strikeout)) + "List given as an argument to `ps-extend-face-list' in `cperl-ps-print'." + :type '(repeat (cons symbol + (cons (choice (const nil) string) + (cons (choice (const nil) string) + (repeat symbol))))) + :group 'cperl-faces) + +(if cperl-can-font-lock + (progn + (defvar cperl-dark-background + (cperl-choose-color "navy" "os2blue" "darkgreen")) + (defvar cperl-dark-foreground + (cperl-choose-color "orchid1" "orange")) + + (defface cperl-nonoverridable-face + (` ((((class grayscale) (background light)) + (:background "Gray90" :italic t :underline t)) + (((class grayscale) (background dark)) + (:foreground "Gray80" :italic t :underline t :bold t)) + (((class color) (background light)) + (:foreground "chartreuse3")) + (((class color) (background dark)) + (:foreground (, cperl-dark-foreground))) + (t (:bold t :underline t)))) + "Font Lock mode face used to highlight array names." + :group 'cperl-faces) + + (defface cperl-array-face + (` ((((class grayscale) (background light)) + (:background "Gray90" :bold t)) + (((class grayscale) (background dark)) + (:foreground "Gray80" :bold t)) + (((class color) (background light)) + (:foreground "Blue" :background "lightyellow2" :bold t)) + (((class color) (background dark)) + (:foreground "yellow" :background (, cperl-dark-background) :bold t)) + (t (:bold t)))) + "Font Lock mode face used to highlight array names." + :group 'cperl-faces) + + (defface cperl-hash-face + (` ((((class grayscale) (background light)) + (:background "Gray90" :bold t :italic t)) + (((class grayscale) (background dark)) + (:foreground "Gray80" :bold t :italic t)) + (((class color) (background light)) + (:foreground "Red" :background "lightyellow2" :bold t :italic t)) + (((class color) (background dark)) + (:foreground "Red" :background (, cperl-dark-background) :bold t :italic t)) + (t (:bold t :italic t)))) + "Font Lock mode face used to highlight hash names." + :group 'cperl-faces))) + + + +;;; Short extra-docs. + +(defvar cperl-tips 'please-ignore-this-line + "Get maybe newer version of this package from + ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs +and/or + ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl +Subdirectory `cperl-mode' may contain yet newer development releases and/or +patches to related files. + +For best results apply to an older Emacs the patches from + ftp://ftp.math.ohio-state.edu/pub/users/ilya/cperl-mode/patches +\(this upgrades syntax-parsing abilities of RMS Emaxen v19.34 and +v20.2 up to the level of RMS Emacs v20.3 - a must for a good Perl +mode.) As of beginning of 2003, XEmacs may provide a similar ability. + +Get support packages choose-color.el (or font-lock-extra.el before +19.30), imenu-go.el from the same place. \(Look for other files there +too... ;-). Get a patch for imenu.el in 19.29. Note that for 19.30 and +later you should use choose-color.el *instead* of font-lock-extra.el +\(and you will not get smart highlighting in C :-(). + +Note that to enable Compile choices in the menu you need to install +mode-compile.el. + +If your Emacs does not default to `cperl-mode' on Perl files, and you +want it to: put the following into your .emacs file: + + (autoload 'perl-mode \"cperl-mode\" \"alternate mode for editing Perl programs\" t) + +or + + (defalias 'perl-mode 'cperl-mode) + +Get perl5-info from + $CPAN/doc/manual/info/perl-info.tar.gz +older version was on + http://www.metronet.com:70/9/perlinfo/perl5/manual/perl5-info.tar.gz + +If you use imenu-go, run imenu on perl5-info buffer (you can do it +from Perl menu). If many files are related, generate TAGS files from +Tools/Tags submenu in Perl menu. + +If some class structure is too complicated, use Tools/Hierarchy-view +from Perl menu, or hierarchic view of imenu. The second one uses the +current buffer only, the first one requires generation of TAGS from +Perl/Tools/Tags menu beforehand. + +Run Perl/Tools/Insert-spaces-if-needed to fix your lazy typing. + +Switch auto-help on/off with Perl/Tools/Auto-help. + +Though with contemporary Emaxen CPerl mode should maintain the correct +parsing of Perl even when editing, sometimes it may be lost. Fix this by + + M-x norm RET + +or + + \\[normal-mode] + +In cases of more severe confusion sometimes it is helpful to do + + M-x load-l RET cperl-mode RET + M-x norm RET + +or + + \\[load-library] cperl-mode RET + \\[normal-mode] + +Before reporting (non-)problems look in the problem section of online +micro-docs on what I know about CPerl problems.") + +(defvar cperl-problems 'please-ignore-this-line + "Description of problems in CPerl mode. +Some faces will not be shown on some versions of Emacs unless you +install choose-color.el, available from + ftp://ftp.math.ohio-state.edu/pub/users/ilya/emacs/ + +`fill-paragraph' on a comment may leave the point behind the +paragraph. Parsing of lines with several <= 19.12 + (setq unread-command-events (list (eval '(character-to-event c)))))) + (defun cperl-putback-char (c) ; XEmacs <= 19.11 + (set 'unread-command-event (eval '(character-to-event c))))) ; Avoid warnings + +(or (fboundp 'uncomment-region) + (defun uncomment-region (beg end) + (interactive "r") + (comment-region beg end -1))) + +(defvar cperl-do-not-fontify + (if (string< emacs-version "19.30") + 'fontified + 'lazy-lock) + "Text property which inhibits refontification.") + +(defsubst cperl-put-do-not-fontify (from to &optional post) + ;; If POST, do not do it with postponed fontification + (if (and post cperl-syntaxify-by-font-lock) + nil + (put-text-property (max (point-min) (1- from)) + to cperl-do-not-fontify t))) + +(defcustom cperl-mode-hook nil + "Hook run by CPerl mode." + :type 'hook + :group 'cperl) + +(defvar cperl-syntax-state nil) +(defvar cperl-syntax-done-to nil) +(defvar cperl-emacs-can-parse (> (length (save-excursion + (parse-partial-sexp (point) (point)))) 9)) + +;; Make customization possible "in reverse" +(defsubst cperl-val (symbol &optional default hairy) + (cond + ((eq (symbol-value symbol) 'null) default) + (cperl-hairy (or hairy t)) + (t (symbol-value symbol)))) + +;;; Probably it is too late to set these guys already, but it can help later: + +(and cperl-clobber-mode-lists + (setq auto-mode-alist + (append '(("\\.\\([pP][Llm]\\|al\\)$" . perl-mode)) auto-mode-alist )) + (and (boundp 'interpreter-mode-alist) + (setq interpreter-mode-alist (append interpreter-mode-alist + '(("miniperl" . perl-mode)))))) +(if (fboundp 'eval-when-compile) + (eval-when-compile + (mapcar (lambda (p) + (condition-case nil + (require p) + (error nil))) + '(imenu easymenu etags timer man info)) + (if (fboundp 'ps-extend-face-list) + (defmacro cperl-ps-extend-face-list (arg) + (` (ps-extend-face-list (, arg)))) + (defmacro cperl-ps-extend-face-list (arg) + (` (error "This version of Emacs has no `ps-extend-face-list'")))) + ;; Calling `cperl-enable-font-lock' below doesn't compile on XEmacs, + ;; macros instead of defsubsts don't work on Emacs, so we do the + ;; expansion manually. Any other suggestions? + (if cperl-can-font-lock + (require 'font-lock)) + (require 'cl))) + +(defvar cperl-mode-abbrev-table nil + "Abbrev table in use in CPerl mode buffers.") + +(add-hook 'edit-var-mode-alist '(perl-mode (regexp . "^cperl-"))) + +(defvar cperl-mode-map () "Keymap used in CPerl mode.") + +(if cperl-mode-map nil + (setq cperl-mode-map (make-sparse-keymap)) + (cperl-define-key "{" 'cperl-electric-lbrace) + (cperl-define-key "[" 'cperl-electric-paren) + (cperl-define-key "(" 'cperl-electric-paren) + (cperl-define-key "<" 'cperl-electric-paren) + (cperl-define-key "}" 'cperl-electric-brace) + (cperl-define-key "]" 'cperl-electric-rparen) + (cperl-define-key ")" 'cperl-electric-rparen) + (cperl-define-key ";" 'cperl-electric-semi) + (cperl-define-key ":" 'cperl-electric-terminator) + (cperl-define-key "\C-j" 'newline-and-indent) + (cperl-define-key "\C-c\C-j" 'cperl-linefeed) + (cperl-define-key "\C-c\C-t" 'cperl-invert-if-unless) + (cperl-define-key "\C-c\C-a" 'cperl-toggle-auto-newline) + (cperl-define-key "\C-c\C-k" 'cperl-toggle-abbrev) + (cperl-define-key "\C-c\C-w" 'cperl-toggle-construct-fix) + (cperl-define-key "\C-c\C-f" 'auto-fill-mode) + (cperl-define-key "\C-c\C-e" 'cperl-toggle-electric) + (cperl-define-key "\C-c\C-ha" 'cperl-toggle-autohelp) + (cperl-define-key "\e\C-q" 'cperl-indent-exp) ; Usually not bound + (cperl-define-key [?\C-\M-\|] 'cperl-lineup + [(control meta |)]) + ;;(cperl-define-key "\M-q" 'cperl-fill-paragraph) + ;;(cperl-define-key "\e;" 'cperl-indent-for-comment) + (cperl-define-key "\177" 'cperl-electric-backspace) + (cperl-define-key "\t" 'cperl-indent-command) + ;; don't clobber the backspace binding: + (cperl-define-key "\C-c\C-hF" 'cperl-info-on-command + [(control c) (control h) F]) + (if (cperl-val 'cperl-clobber-lisp-bindings) + (progn + (cperl-define-key "\C-hf" + ;;(concat (char-to-string help-char) "f") ; does not work + 'cperl-info-on-command + [(control h) f]) + (cperl-define-key "\C-hv" + ;;(concat (char-to-string help-char) "v") ; does not work + 'cperl-get-help + [(control h) v]) + (cperl-define-key "\C-c\C-hf" + ;;(concat (char-to-string help-char) "f") ; does not work + (key-binding "\C-hf") + [(control c) (control h) f]) + (cperl-define-key "\C-c\C-hv" + ;;(concat (char-to-string help-char) "v") ; does not work + (key-binding "\C-hv") + [(control c) (control h) v])) + (cperl-define-key "\C-c\C-hf" 'cperl-info-on-current-command + [(control c) (control h) f]) + (cperl-define-key "\C-c\C-hv" + ;;(concat (char-to-string help-char) "v") ; does not work + 'cperl-get-help + [(control c) (control h) v])) + (if (and cperl-xemacs-p + (<= emacs-minor-version 11) (<= emacs-major-version 19)) + (progn + ;; substitute-key-definition is usefulness-deenhanced... + (cperl-define-key "\M-q" 'cperl-fill-paragraph) + (cperl-define-key "\e;" 'cperl-indent-for-comment) + (cperl-define-key "\e\C-\\" 'cperl-indent-region)) + (substitute-key-definition + 'indent-sexp 'cperl-indent-exp + cperl-mode-map global-map) + (substitute-key-definition + 'fill-paragraph 'cperl-fill-paragraph + cperl-mode-map global-map) + (substitute-key-definition + 'indent-region 'cperl-indent-region + cperl-mode-map global-map) + (substitute-key-definition + 'indent-for-comment 'cperl-indent-for-comment + cperl-mode-map global-map))) + +(defvar cperl-menu) +(defvar cperl-lazy-installed) +(defvar cperl-old-style nil) +(condition-case nil + (progn + (require 'easymenu) + (easy-menu-define + cperl-menu cperl-mode-map "Menu for CPerl mode" + '("Perl" + ["Beginning of function" beginning-of-defun t] + ["End of function" end-of-defun t] + ["Mark function" mark-defun t] + ["Indent expression" cperl-indent-exp t] + ["Fill paragraph/comment" cperl-fill-paragraph t] + "----" + ["Line up a construction" cperl-lineup (cperl-use-region-p)] + ["Invert if/unless/while etc" cperl-invert-if-unless t] + ("Regexp" + ["Beautify" cperl-beautify-regexp + cperl-use-syntax-table-text-property] + ["Beautify one level deep" (cperl-beautify-regexp 1) + cperl-use-syntax-table-text-property] + ["Beautify a group" cperl-beautify-level + cperl-use-syntax-table-text-property] + ["Beautify a group one level deep" (cperl-beautify-level 1) + cperl-use-syntax-table-text-property] + ["Contract a group" cperl-contract-level + cperl-use-syntax-table-text-property] + ["Contract groups" cperl-contract-levels + cperl-use-syntax-table-text-property]) + ["Refresh \"hard\" constructions" cperl-find-pods-heres t] + "----" + ["Indent region" cperl-indent-region (cperl-use-region-p)] + ["Comment region" cperl-comment-region (cperl-use-region-p)] + ["Uncomment region" cperl-uncomment-region (cperl-use-region-p)] + "----" + ["Run" mode-compile (fboundp 'mode-compile)] + ["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill) + (get-buffer "*compilation*"))] + ["Next error" next-error (get-buffer "*compilation*")] + ["Check syntax" cperl-check-syntax (fboundp 'mode-compile)] + "----" + ["Debugger" cperl-db t] + "----" + ("Tools" + ["Imenu" imenu (fboundp 'imenu)] + ["Insert spaces if needed" cperl-find-bad-style t] + ["Class Hierarchy from TAGS" cperl-tags-hier-init t] + ;;["Update classes" (cperl-tags-hier-init t) tags-table-list] + ["CPerl pretty print (exprmntl)" cperl-ps-print + (fboundp 'ps-extend-face-list)] + ["Imenu on info" cperl-imenu-on-info (featurep 'imenu)] + ("Tags" +;;; ["Create tags for current file" cperl-etags t] +;;; ["Add tags for current file" (cperl-etags t) t] +;;; ["Create tags for Perl files in directory" (cperl-etags nil t) t] +;;; ["Add tags for Perl files in directory" (cperl-etags t t) t] +;;; ["Create tags for Perl files in (sub)directories" +;;; (cperl-etags nil 'recursive) t] +;;; ["Add tags for Perl files in (sub)directories" +;;; (cperl-etags t 'recursive) t]) +;;;; cperl-write-tags (&optional file erase recurse dir inbuffer) + ["Create tags for current file" (cperl-write-tags nil t) t] + ["Add tags for current file" (cperl-write-tags) t] + ["Create tags for Perl files in directory" + (cperl-write-tags nil t nil t) t] + ["Add tags for Perl files in directory" + (cperl-write-tags nil nil nil t) t] + ["Create tags for Perl files in (sub)directories" + (cperl-write-tags nil t t t) t] + ["Add tags for Perl files in (sub)directories" + (cperl-write-tags nil nil t t) t])) + ("Perl docs" + ["Define word at point" imenu-go-find-at-position + (fboundp 'imenu-go-find-at-position)] + ["Help on function" cperl-info-on-command t] + ["Help on function at point" cperl-info-on-current-command t] + ["Help on symbol at point" cperl-get-help t] + ["Perldoc" cperl-perldoc t] + ["Perldoc on word at point" cperl-perldoc-at-point t] + ["View manpage of POD in this file" cperl-build-manpage t] + ["Auto-help on" cperl-lazy-install + (and (fboundp 'run-with-idle-timer) + (not cperl-lazy-installed))] + ["Auto-help off" cperl-lazy-unstall + (and (fboundp 'run-with-idle-timer) + cperl-lazy-installed)]) + ("Toggle..." + ["Auto newline" cperl-toggle-auto-newline t] + ["Electric parens" cperl-toggle-electric t] + ["Electric keywords" cperl-toggle-abbrev t] + ["Fix whitespace on indent" cperl-toggle-construct-fix t] + ["Auto-help on Perl constructs" cperl-toggle-autohelp t] + ["Auto fill" auto-fill-mode t]) + ("Indent styles..." + ["CPerl" (cperl-set-style "CPerl") t] + ["PerlStyle" (cperl-set-style "PerlStyle") t] + ["GNU" (cperl-set-style "GNU") t] + ["C++" (cperl-set-style "C++") t] + ["FSF" (cperl-set-style "FSF") t] + ["BSD" (cperl-set-style "BSD") t] + ["Whitesmith" (cperl-set-style "Whitesmith") t] + ["Current" (cperl-set-style "Current") t] + ["Memorized" (cperl-set-style-back) cperl-old-style]) + ("Micro-docs" + ["Tips" (describe-variable 'cperl-tips) t] + ["Problems" (describe-variable 'cperl-problems) t] + ["Non-problems" (describe-variable 'cperl-non-problems) t] + ["Speed" (describe-variable 'cperl-speed) t] + ["Praise" (describe-variable 'cperl-praise) t] + ["Faces" (describe-variable 'cperl-tips-faces) t] + ["CPerl mode" (describe-function 'cperl-mode) t] + ["CPerl version" + (message "The version of master-file for this CPerl is %s" + cperl-version) t])))) + (error nil)) + +(autoload 'c-macro-expand "cmacexp" + "Display the result of expanding all C macros occurring in the region. +The expansion is entirely correct because it uses the C preprocessor." + t) + +(defvar cperl-imenu--function-name-regexp-perl + (concat + "^\\(" + "[ \t]*\\(sub\\|package\\)[ \t\n]+\\([a-zA-Z_0-9:']+\\)[ \t]*\\(([^()]*)[ \t]*\\)?" + "\\|" + "=head\\([12]\\)[ \t]+\\([^\n]+\\)$" + "\\)")) + +(defvar cperl-outline-regexp + (concat cperl-imenu--function-name-regexp-perl "\\|" "\\`")) + +(defvar cperl-mode-syntax-table nil + "Syntax table in use in CPerl mode buffers.") + +(defvar cperl-string-syntax-table nil + "Syntax table in use in CPerl mode string-like chunks.") + +(if cperl-mode-syntax-table + () + (setq cperl-mode-syntax-table (make-syntax-table)) + (modify-syntax-entry ?\\ "\\" cperl-mode-syntax-table) + (modify-syntax-entry ?/ "." cperl-mode-syntax-table) + (modify-syntax-entry ?* "." cperl-mode-syntax-table) + (modify-syntax-entry ?+ "." cperl-mode-syntax-table) + (modify-syntax-entry ?- "." cperl-mode-syntax-table) + (modify-syntax-entry ?= "." cperl-mode-syntax-table) + (modify-syntax-entry ?% "." cperl-mode-syntax-table) + (modify-syntax-entry ?< "." cperl-mode-syntax-table) + (modify-syntax-entry ?> "." cperl-mode-syntax-table) + (modify-syntax-entry ?& "." cperl-mode-syntax-table) + (modify-syntax-entry ?$ "\\" cperl-mode-syntax-table) + (modify-syntax-entry ?\n ">" cperl-mode-syntax-table) + (modify-syntax-entry ?# "<" cperl-mode-syntax-table) + (modify-syntax-entry ?' "\"" cperl-mode-syntax-table) + (modify-syntax-entry ?` "\"" cperl-mode-syntax-table) + (if cperl-under-as-char + (modify-syntax-entry ?_ "w" cperl-mode-syntax-table)) + (modify-syntax-entry ?: "_" cperl-mode-syntax-table) + (modify-syntax-entry ?| "." cperl-mode-syntax-table) + (setq cperl-string-syntax-table (copy-syntax-table cperl-mode-syntax-table)) + (modify-syntax-entry ?$ "." cperl-string-syntax-table) + (modify-syntax-entry ?# "." cperl-string-syntax-table)) ; (?# comment ) + + + +;; provide an alias for working with emacs 19. the perl-mode that comes +;; with it is really bad, and this lets us seamlessly replace it. +;;;###autoload +(fset 'perl-mode 'cperl-mode) +(defvar cperl-faces-init nil) +;; Fix for msb.el +(defvar cperl-msb-fixed nil) +(defvar font-lock-syntactic-keywords) +(defvar perl-font-lock-keywords) +(defvar perl-font-lock-keywords-1) +(defvar perl-font-lock-keywords-2) +(defvar outline-level) +(if (fboundp 'defvaralias) + (let ((f 'defvaralias)) ; Some functions deduce stuff from the mode name... + (funcall f 'cperl-font-lock-keywords 'perl-font-lock-keywords) + (funcall f 'cperl-font-lock-keywords-1 'perl-font-lock-keywords-1) + (funcall f 'cperl-font-lock-keywords-2 'perl-font-lock-keywords-2))) + +(defvar cperl-use-major-mode 'perl-mode) + +;;;###autoload +(defun cperl-mode () + "Major mode for editing Perl code. +Expression and list commands understand all C brackets. +Tab indents for Perl code. +Paragraphs are separated by blank lines only. +Delete converts tabs to spaces as it moves back. + +Various characters in Perl almost always come in pairs: {}, (), [], +sometimes <>. When the user types the first, she gets the second as +well, with optional special formatting done on {}. (Disabled by +default.) You can always quote (with \\[quoted-insert]) the left +\"paren\" to avoid the expansion. The processing of < is special, +since most the time you mean \"less\". CPerl mode tries to guess +whether you want to type pair <>, and inserts is if it +appropriate. You can set `cperl-electric-parens-string' to the string that +contains the parenths from the above list you want to be electrical. +Electricity of parenths is controlled by `cperl-electric-parens'. +You may also set `cperl-electric-parens-mark' to have electric parens +look for active mark and \"embrace\" a region if possible.' + +CPerl mode provides expansion of the Perl control constructs: + + if, else, elsif, unless, while, until, continue, do, + for, foreach, formy and foreachmy. + +and POD directives (Disabled by default, see `cperl-electric-keywords'.) + +The user types the keyword immediately followed by a space, which +causes the construct to be expanded, and the point is positioned where +she is most likely to want to be. eg. when the user types a space +following \"if\" the following appears in the buffer: if () { or if () +} { } and the cursor is between the parentheses. The user can then +type some boolean expression within the parens. Having done that, +typing \\[cperl-linefeed] places you - appropriately indented - on a +new line between the braces (if you typed \\[cperl-linefeed] in a POD +directive line, then appropriate number of new lines is inserted). + +If CPerl decides that you want to insert \"English\" style construct like + + bite if angry; + +it will not do any expansion. See also help on variable +`cperl-extra-newline-before-brace'. (Note that one can switch the +help message on expansion by setting `cperl-message-electric-keyword' +to nil.) + +\\[cperl-linefeed] is a convenience replacement for typing carriage +return. It places you in the next line with proper indentation, or if +you type it inside the inline block of control construct, like + + foreach (@lines) {print; print} + +and you are on a boundary of a statement inside braces, it will +transform the construct into a multiline and will place you into an +appropriately indented blank line. If you need a usual +`newline-and-indent' behaviour, it is on \\[newline-and-indent], +see documentation on `cperl-electric-linefeed'. + +Use \\[cperl-invert-if-unless] to change a construction of the form + + if (A) { B } + +into + + B if A; + +\\{cperl-mode-map} + +Setting the variable `cperl-font-lock' to t switches on font-lock-mode +\(even with older Emacsen), `cperl-electric-lbrace-space' to t switches +on electric space between $ and {, `cperl-electric-parens-string' is +the string that contains parentheses that should be electric in CPerl +\(see also `cperl-electric-parens-mark' and `cperl-electric-parens'), +setting `cperl-electric-keywords' enables electric expansion of +control structures in CPerl. `cperl-electric-linefeed' governs which +one of two linefeed behavior is preferable. You can enable all these +options simultaneously (recommended mode of use) by setting +`cperl-hairy' to t. In this case you can switch separate options off +by setting them to `null'. Note that one may undo the extra +whitespace inserted by semis and braces in `auto-newline'-mode by +consequent \\[cperl-electric-backspace]. + +If your site has perl5 documentation in info format, you can use commands +\\[cperl-info-on-current-command] and \\[cperl-info-on-command] to access it. +These keys run commands `cperl-info-on-current-command' and +`cperl-info-on-command', which one is which is controlled by variable +`cperl-info-on-command-no-prompt' and `cperl-clobber-lisp-bindings' +\(in turn affected by `cperl-hairy'). + +Even if you have no info-format documentation, short one-liner-style +help is available on \\[cperl-get-help], and one can run perldoc or +man via menu. + +It is possible to show this help automatically after some idle time. +This is regulated by variable `cperl-lazy-help-time'. Default with +`cperl-hairy' (if the value of `cperl-lazy-help-time' is nil) is 5 +secs idle time . It is also possible to switch this on/off from the +menu, or via \\[cperl-toggle-autohelp]. Requires `run-with-idle-timer'. + +Use \\[cperl-lineup] to vertically lineup some construction - put the +beginning of the region at the start of construction, and make region +span the needed amount of lines. + +Variables `cperl-pod-here-scan', `cperl-pod-here-fontify', +`cperl-pod-face', `cperl-pod-head-face' control processing of POD and +here-docs sections. With capable Emaxen results of scan are used +for indentation too, otherwise they are used for highlighting only. + +Variables controlling indentation style: + `cperl-tab-always-indent' + Non-nil means TAB in CPerl mode should always reindent the current line, + regardless of where in the line point is when the TAB command is used. + `cperl-indent-left-aligned-comments' + Non-nil means that the comment starting in leftmost column should indent. + `cperl-auto-newline' + Non-nil means automatically newline before and after braces, + and after colons and semicolons, inserted in Perl code. The following + \\[cperl-electric-backspace] will remove the inserted whitespace. + Insertion after colons requires both this variable and + `cperl-auto-newline-after-colon' set. + `cperl-auto-newline-after-colon' + Non-nil means automatically newline even after colons. + Subject to `cperl-auto-newline' setting. + `cperl-indent-level' + Indentation of Perl statements within surrounding block. + The surrounding block's indentation is the indentation + of the line on which the open-brace appears. + `cperl-continued-statement-offset' + Extra indentation given to a substatement, such as the + then-clause of an if, or body of a while, or just a statement continuation. + `cperl-continued-brace-offset' + Extra indentation given to a brace that starts a substatement. + This is in addition to `cperl-continued-statement-offset'. + `cperl-brace-offset' + Extra indentation for line if it starts with an open brace. + `cperl-brace-imaginary-offset' + An open brace following other text is treated as if it the line started + this far to the right of the actual line indentation. + `cperl-label-offset' + Extra indentation for line that is a label. + `cperl-min-label-indent' + Minimal indentation for line that is a label. + +Settings for K&R and BSD indentation styles are + `cperl-indent-level' 5 8 + `cperl-continued-statement-offset' 5 8 + `cperl-brace-offset' -5 -8 + `cperl-label-offset' -5 -8 + +CPerl knows several indentation styles, and may bulk set the +corresponding variables. Use \\[cperl-set-style] to do this. Use +\\[cperl-set-style-back] to restore the memorized preexisting values +\(both available from menu). + +If `cperl-indent-level' is 0, the statement after opening brace in +column 0 is indented on +`cperl-brace-offset'+`cperl-continued-statement-offset'. + +Turning on CPerl mode calls the hooks in the variable `cperl-mode-hook' +with no args. + +DO NOT FORGET to read micro-docs (available from `Perl' menu) +or as help on variables `cperl-tips', `cperl-problems', +`cperl-non-problems', `cperl-praise', `cperl-speed'." + (interactive) + (kill-all-local-variables) + (use-local-map cperl-mode-map) + (if (cperl-val 'cperl-electric-linefeed) + (progn + (local-set-key "\C-J" 'cperl-linefeed) + (local-set-key "\C-C\C-J" 'newline-and-indent))) + (if (and + (cperl-val 'cperl-clobber-lisp-bindings) + (cperl-val 'cperl-info-on-command-no-prompt)) + (progn + ;; don't clobber the backspace binding: + (cperl-define-key "\C-hf" 'cperl-info-on-current-command [(control h) f]) + (cperl-define-key "\C-c\C-hf" 'cperl-info-on-command + [(control c) (control h) f]))) + (setq major-mode cperl-use-major-mode) + (setq mode-name "CPerl") + (if (not cperl-mode-abbrev-table) + (let ((prev-a-c abbrevs-changed)) + (define-abbrev-table 'cperl-mode-abbrev-table '( + ("if" "if" cperl-electric-keyword 0) + ("elsif" "elsif" cperl-electric-keyword 0) + ("while" "while" cperl-electric-keyword 0) + ("until" "until" cperl-electric-keyword 0) + ("unless" "unless" cperl-electric-keyword 0) + ("else" "else" cperl-electric-else 0) + ("continue" "continue" cperl-electric-else 0) + ("for" "for" cperl-electric-keyword 0) + ("foreach" "foreach" cperl-electric-keyword 0) + ("formy" "formy" cperl-electric-keyword 0) + ("foreachmy" "foreachmy" cperl-electric-keyword 0) + ("do" "do" cperl-electric-keyword 0) + ("=pod" "=pod" cperl-electric-pod 0) + ("=over" "=over" cperl-electric-pod 0) + ("=head1" "=head1" cperl-electric-pod 0) + ("=head2" "=head2" cperl-electric-pod 0) + ("pod" "pod" cperl-electric-pod 0) + ("over" "over" cperl-electric-pod 0) + ("head1" "head1" cperl-electric-pod 0) + ("head2" "head2" cperl-electric-pod 0))) + (setq abbrevs-changed prev-a-c))) + (setq local-abbrev-table cperl-mode-abbrev-table) + (abbrev-mode (if (cperl-val 'cperl-electric-keywords) 1 0)) + (set-syntax-table cperl-mode-syntax-table) + (make-local-variable 'outline-regexp) + ;; (setq outline-regexp imenu-example--function-name-regexp-perl) + (setq outline-regexp cperl-outline-regexp) + (make-local-variable 'outline-level) + (setq outline-level 'cperl-outline-level) + (make-local-variable 'paragraph-start) + (setq paragraph-start (concat "^$\\|" page-delimiter)) + (make-local-variable 'paragraph-separate) + (setq paragraph-separate paragraph-start) + (make-local-variable 'paragraph-ignore-fill-prefix) + (setq paragraph-ignore-fill-prefix t) + (make-local-variable 'indent-line-function) + (setq indent-line-function 'cperl-indent-line) + (make-local-variable 'require-final-newline) + (setq require-final-newline t) + (make-local-variable 'comment-start) + (setq comment-start "# ") + (make-local-variable 'comment-end) + (setq comment-end "") + (make-local-variable 'comment-column) + (setq comment-column cperl-comment-column) + (make-local-variable 'comment-start-skip) + (setq comment-start-skip "#+ *") + (make-local-variable 'defun-prompt-regexp) + (setq defun-prompt-regexp "^[ \t]*sub[ \t]+\\([^ \t\n{(;]+\\)\\([ \t]*([^()]*)[ \t]*\\)?[ \t]*") + (make-local-variable 'comment-indent-function) + (setq comment-indent-function 'cperl-comment-indent) + (make-local-variable 'parse-sexp-ignore-comments) + (setq parse-sexp-ignore-comments t) + (make-local-variable 'indent-region-function) + (setq indent-region-function 'cperl-indent-region) + ;;(setq auto-fill-function 'cperl-do-auto-fill) ; Need to switch on and off! + (make-local-variable 'imenu-create-index-function) + (setq imenu-create-index-function + (function cperl-imenu--create-perl-index)) + (make-local-variable 'imenu-sort-function) + (setq imenu-sort-function nil) + (make-local-variable 'vc-header-alist) + (set 'vc-header-alist cperl-vc-header-alist) ; Avoid warning + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults + (cond + ((string< emacs-version "19.30") + '(perl-font-lock-keywords-2)) + ((string< emacs-version "19.33") ; Which one to use? + '((perl-font-lock-keywords + perl-font-lock-keywords-1 + perl-font-lock-keywords-2))) + (t + '((cperl-load-font-lock-keywords + cperl-load-font-lock-keywords-1 + cperl-load-font-lock-keywords-2))))) + (make-local-variable 'cperl-syntax-state) + (if cperl-use-syntax-table-text-property + (progn + (make-local-variable 'parse-sexp-lookup-properties) + ;; Do not introduce variable if not needed, we check it! + (set 'parse-sexp-lookup-properties t) + ;; Fix broken font-lock: + (or (boundp 'font-lock-unfontify-region-function) + (set 'font-lock-unfontify-region-function + 'font-lock-default-unfontify-region)) + (make-local-variable 'font-lock-unfontify-region-function) + (set 'font-lock-unfontify-region-function ; not present with old Emacs + 'cperl-font-lock-unfontify-region-function) + (make-local-variable 'cperl-syntax-done-to) + ;; Another bug: unless font-lock-syntactic-keywords, font-lock + ;; ignores syntax-table text-property. (t) is a hack + ;; to make font-lock think that font-lock-syntactic-keywords + ;; are defined + (make-local-variable 'font-lock-syntactic-keywords) + (setq font-lock-syntactic-keywords + (if cperl-syntaxify-by-font-lock + '(t (cperl-fontify-syntaxically)) + '(t))))) + (make-local-variable 'cperl-old-style) + (if (boundp 'normal-auto-fill-function) ; 19.33 and later + (set (make-local-variable 'normal-auto-fill-function) + 'cperl-do-auto-fill) ; RMS has it as #'cperl-do-auto-fill ??? + (or (fboundp 'cperl-old-auto-fill-mode) + (progn + (fset 'cperl-old-auto-fill-mode (symbol-function 'auto-fill-mode)) + (defun auto-fill-mode (&optional arg) + (interactive "P") + (eval '(cperl-old-auto-fill-mode arg)) ; Avoid a warning + (and auto-fill-function (memq major-mode '(perl-mode cperl-mode)) + (setq auto-fill-function 'cperl-do-auto-fill)))))) + (if (cperl-enable-font-lock) + (if (cperl-val 'cperl-font-lock) + (progn (or cperl-faces-init (cperl-init-faces)) + (font-lock-mode 1)))) + (and (boundp 'msb-menu-cond) + (not cperl-msb-fixed) + (cperl-msb-fix)) + (if (featurep 'easymenu) + (easy-menu-add cperl-menu)) ; A NOP in RMS Emacs. + (run-hooks 'cperl-mode-hook) + ;; After hooks since fontification will break this + (if cperl-pod-here-scan + (or cperl-syntaxify-by-font-lock + (progn (or cperl-faces-init (cperl-init-faces-weak)) + (cperl-find-pods-heres))))) + +;; Fix for perldb - make default reasonable +(defun cperl-db () + (interactive) + (require 'gud) + (perldb (read-from-minibuffer "Run perldb (like this): " + (if (consp gud-perldb-history) + (car gud-perldb-history) + (concat "perl " ;;(file-name-nondirectory + ;; I have problems + ;; in OS/2 + ;; otherwise + (buffer-file-name))) + nil nil + '(gud-perldb-history . 1)))) + +(defun cperl-msb-fix () + ;; Adds perl files to msb menu, supposes that msb is already loaded + (setq cperl-msb-fixed t) + (let* ((l (length msb-menu-cond)) + (last (nth (1- l) msb-menu-cond)) + (precdr (nthcdr (- l 2) msb-menu-cond)) ; cdr of this is last + (handle (1- (nth 1 last)))) + (setcdr precdr (list + (list + '(memq major-mode '(cperl-mode perl-mode)) + handle + "Perl Files (%d)") + last)))) + +;; This is used by indent-for-comment +;; to decide how much to indent a comment in CPerl code +;; based on its context. Do fallback if comment is found wrong. + +(defvar cperl-wrong-comment) +(defvar cperl-st-cfence '(14)) ; Comment-fence +(defvar cperl-st-sfence '(15)) ; String-fence +(defvar cperl-st-punct '(1)) +(defvar cperl-st-word '(2)) +(defvar cperl-st-bra '(4 . ?\>)) +(defvar cperl-st-ket '(5 . ?\<)) + + +(defun cperl-comment-indent () + (let ((p (point)) (c (current-column)) was phony) + (if (looking-at "^#") 0 ; Existing comment at bol stays there. + ;; Wrong comment found + (save-excursion + (setq was (cperl-to-comment-or-eol) + phony (eq (get-text-property (point) 'syntax-table) + cperl-st-cfence)) + (if phony + (progn + (re-search-forward "#\\|$") ; Hmm, what about embedded #? + (if (eq (preceding-char) ?\#) + (forward-char -1)) + (setq was nil))) + (if (= (point) p) + (progn + (skip-chars-backward " \t") + (max (1+ (current-column)) ; Else indent at comment column + comment-column)) + (if was nil + (insert comment-start) + (backward-char (length comment-start))) + (setq cperl-wrong-comment t) + (indent-to comment-column 1) ; Indent minimum 1 + c))))) ; except leave at least one space. + +;;;(defun cperl-comment-indent-fallback () +;;; "Is called if the standard comment-search procedure fails. +;;;Point is at start of real comment." +;;; (let ((c (current-column)) target cnt prevc) +;;; (if (= c comment-column) nil +;;; (setq cnt (skip-chars-backward "[ \t]")) +;;; (setq target (max (1+ (setq prevc +;;; (current-column))) ; Else indent at comment column +;;; comment-column)) +;;; (if (= c comment-column) nil +;;; (delete-backward-char cnt) +;;; (while (< prevc target) +;;; (insert "\t") +;;; (setq prevc (current-column))) +;;; (if (> prevc target) (progn (delete-char -1) (setq prevc (current-column)))) +;;; (while (< prevc target) +;;; (insert " ") +;;; (setq prevc (current-column))))))) + +(defun cperl-indent-for-comment () + "Substitute for `indent-for-comment' in CPerl." + (interactive) + (let (cperl-wrong-comment) + (indent-for-comment) + (if cperl-wrong-comment + (progn (cperl-to-comment-or-eol) + (forward-char (length comment-start)))))) + +(defun cperl-comment-region (b e arg) + "Comment or uncomment each line in the region in CPerl mode. +See `comment-region'." + (interactive "r\np") + (let ((comment-start "#")) + (comment-region b e arg))) + +(defun cperl-uncomment-region (b e arg) + "Uncomment or comment each line in the region in CPerl mode. +See `comment-region'." + (interactive "r\np") + (let ((comment-start "#")) + (comment-region b e (- arg)))) + +(defvar cperl-brace-recursing nil) + +(defun cperl-electric-brace (arg &optional only-before) + "Insert character and correct line's indentation. +If ONLY-BEFORE and `cperl-auto-newline', will insert newline before the +place (even in empty line), but not after. If after \")\" and the inserted +char is \"{\", insert extra newline before only if +`cperl-extra-newline-before-brace'." + (interactive "P") + (let (insertpos + (other-end (if (and cperl-electric-parens-mark + (cperl-mark-active) + (< (mark) (point))) + (mark) + nil))) + (if (and other-end + (not cperl-brace-recursing) + (cperl-val 'cperl-electric-parens) + (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point))) + ;; Need to insert a matching pair + (progn + (save-excursion + (setq insertpos (point-marker)) + (goto-char other-end) + (setq last-command-char ?\{) + (cperl-electric-lbrace arg insertpos)) + (forward-char 1)) + ;; Check whether we close something "usual" with `}' + (if (and (eq last-command-char ?\}) + (not + (condition-case nil + (save-excursion + (up-list (- (prefix-numeric-value arg))) + ;;(cperl-after-block-p (point-min)) + (or (cperl-after-expr-p nil "{;)") + ;; after sub, else, continue + (cperl-after-block-p nil 'pre))) + (error nil)))) + ;; Just insert the guy + (self-insert-command (prefix-numeric-value arg)) + (if (and (not arg) ; No args, end (of empty line or auto) + (eolp) + (or (and (null only-before) + (save-excursion + (skip-chars-backward " \t") + (bolp))) + (and (eq last-command-char ?\{) ; Do not insert newline + ;; if after ")" and `cperl-extra-newline-before-brace' + ;; is nil, do not insert extra newline. + (not cperl-extra-newline-before-brace) + (save-excursion + (skip-chars-backward " \t") + (eq (preceding-char) ?\)))) + (if cperl-auto-newline + (progn (cperl-indent-line) (newline) t) nil))) + (progn + (self-insert-command (prefix-numeric-value arg)) + (cperl-indent-line) + (if cperl-auto-newline + (setq insertpos (1- (point)))) + (if (and cperl-auto-newline (null only-before)) + (progn + (newline) + (cperl-indent-line))) + (save-excursion + (if insertpos (progn (goto-char insertpos) + (search-forward (make-string + 1 last-command-char)) + (setq insertpos (1- (point))))) + (delete-char -1)))) + (if insertpos + (save-excursion + (goto-char insertpos) + (self-insert-command (prefix-numeric-value arg))) + (self-insert-command (prefix-numeric-value arg))))))) + +(defun cperl-electric-lbrace (arg &optional end) + "Insert character, correct line's indentation, correct quoting by space." + (interactive "P") + (let ((cperl-brace-recursing t) + (cperl-auto-newline cperl-auto-newline) + (other-end (or end + (if (and cperl-electric-parens-mark + (cperl-mark-active) + (> (mark) (point))) + (save-excursion + (goto-char (mark)) + (point-marker)) + nil))) + pos after) + (and (cperl-val 'cperl-electric-lbrace-space) + (eq (preceding-char) ?$) + (save-excursion + (skip-chars-backward "$") + (looking-at "\\(\\$\\$\\)*\\$\\([^\\$]\\|$\\)")) + (insert ?\ )) + ;; Check whether we are in comment + (if (and + (save-excursion + (beginning-of-line) + (not (looking-at "[ \t]*#"))) + (cperl-after-expr-p nil "{;)")) + nil + (setq cperl-auto-newline nil)) + (cperl-electric-brace arg) + (and (cperl-val 'cperl-electric-parens) + (eq last-command-char ?{) + (memq last-command-char + (append cperl-electric-parens-string nil)) + (or (if other-end (goto-char (marker-position other-end))) + t) + (setq last-command-char ?} pos (point)) + (progn (cperl-electric-brace arg t) + (goto-char pos))))) + +(defun cperl-electric-paren (arg) + "Insert an opening parenthesis or a matching pair of parentheses. +See `cperl-electric-parens'." + (interactive "P") + (let ((beg (save-excursion (beginning-of-line) (point))) + (other-end (if (and cperl-electric-parens-mark + (cperl-mark-active) + (> (mark) (point))) + (save-excursion + (goto-char (mark)) + (point-marker)) + nil))) + (if (and (cperl-val 'cperl-electric-parens) + (memq last-command-char + (append cperl-electric-parens-string nil)) + (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point)) + ;;(not (save-excursion (search-backward "#" beg t))) + (if (eq last-command-char ?<) + (progn + (and abbrev-mode ; later it is too late, may be after `for' + (expand-abbrev)) + (cperl-after-expr-p nil "{;(,:=")) + 1)) + (progn + (self-insert-command (prefix-numeric-value arg)) + (if other-end (goto-char (marker-position other-end))) + (insert (make-string + (prefix-numeric-value arg) + (cdr (assoc last-command-char '((?{ .?}) + (?[ . ?]) + (?( . ?)) + (?< . ?>)))))) + (forward-char (- (prefix-numeric-value arg)))) + (self-insert-command (prefix-numeric-value arg))))) + +(defun cperl-electric-rparen (arg) + "Insert a matching pair of parentheses if marking is active. +If not, or if we are not at the end of marking range, would self-insert. +Affected by `cperl-electric-parens'." + (interactive "P") + (let ((beg (save-excursion (beginning-of-line) (point))) + (other-end (if (and cperl-electric-parens-mark + (cperl-val 'cperl-electric-parens) + (memq last-command-char + (append cperl-electric-parens-string nil)) + (cperl-mark-active) + (< (mark) (point))) + (mark) + nil)) + p) + (if (and other-end + (cperl-val 'cperl-electric-parens) + (memq last-command-char '( ?\) ?\] ?\} ?\> )) + (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point)) + ;;(not (save-excursion (search-backward "#" beg t))) + ) + (progn + (self-insert-command (prefix-numeric-value arg)) + (setq p (point)) + (if other-end (goto-char other-end)) + (insert (make-string + (prefix-numeric-value arg) + (cdr (assoc last-command-char '((?\} . ?\{) + (?\] . ?\[) + (?\) . ?\() + (?\> . ?\<)))))) + (goto-char (1+ p))) + (self-insert-command (prefix-numeric-value arg))))) + +(defun cperl-electric-keyword () + "Insert a construction appropriate after a keyword. +Help message may be switched off by setting `cperl-message-electric-keyword' +to nil." + (let ((beg (save-excursion (beginning-of-line) (point))) + (dollar (and (eq last-command-char ?$) + (eq this-command 'self-insert-command))) + (delete (and (memq last-command-char '(?\ ?\n ?\t ?\f)) + (memq this-command '(self-insert-command newline)))) + my do) + (and (save-excursion + (condition-case nil + (progn + (backward-sexp 1) + (setq do (looking-at "do\\>"))) + (error nil)) + (cperl-after-expr-p nil "{;:")) + (save-excursion + (not + (re-search-backward + "[#\"'`]\\|\\" + beg t))) + (save-excursion (or (not (re-search-backward "^=" nil t)) + (or + (looking-at "=cut") + (and cperl-use-syntax-table-text-property + (not (eq (get-text-property (point) + 'syntax-type) + 'pod)))))) + (save-excursion (forward-sexp -1) + (not (memq (following-char) (append "$@%&*" nil)))) + (progn + (and (eq (preceding-char) ?y) + (progn ; "foreachmy" + (forward-char -2) + (insert " ") + (forward-char 2) + (setq my t dollar t + delete + (memq this-command '(self-insert-command newline))))) + (and dollar (insert " $")) + (cperl-indent-line) + ;;(insert " () {\n}") + (cond + (cperl-extra-newline-before-brace + (insert (if do "\n" " ()\n")) + (insert "{") + (cperl-indent-line) + (insert "\n") + (cperl-indent-line) + (insert "\n}") + (and do (insert " while ();"))) + (t + (insert (if do " {\n} while ();" " () {\n}")))) + (or (looking-at "[ \t]\\|$") (insert " ")) + (cperl-indent-line) + (if dollar (progn (search-backward "$") + (if my + (forward-char 1) + (delete-char 1))) + (search-backward ")") + (if (eq last-command-char ?\() + (progn ; Avoid "if (())" + (delete-backward-char 1) + (delete-backward-char -1)))) + (if delete + (cperl-putback-char cperl-del-back-ch)) + (if cperl-message-electric-keyword + (message "Precede char by C-q to avoid expansion")))))) + +(defun cperl-ensure-newlines (n &optional pos) + "Make sure there are N newlines after the point." + (or pos (setq pos (point))) + (if (looking-at "\n") + (forward-char 1) + (insert "\n")) + (if (> n 1) + (cperl-ensure-newlines (1- n) pos) + (goto-char pos))) + +(defun cperl-electric-pod () + "Insert a POD chunk appropriate after a =POD directive." + (let ((delete (and (memq last-command-char '(?\ ?\n ?\t ?\f)) + (memq this-command '(self-insert-command newline)))) + head1 notlast name p really-delete over) + (and (save-excursion + (forward-word -1) + (and + (eq (preceding-char) ?=) + (progn + (setq head1 (looking-at "head1\\>[ \t]*$")) + (setq over (and (looking-at "over\\>[ \t]*$") + (not (looking-at "over[ \t]*\n\n\n*=item\\>")))) + (forward-char -1) + (bolp)) + (or + (get-text-property (point) 'in-pod) + (cperl-after-expr-p nil "{;:") + (and (re-search-backward + ;; "\\(\\`\n?\\|\n\n\\)=\\sw+" + "\\(\\`\n?\\|^\n\\)=\\sw+" + (point-min) t) + (not (or + (looking-at "=cut") + (and cperl-use-syntax-table-text-property + (not (eq (get-text-property (point) 'syntax-type) + 'pod))))))))) + (progn + (save-excursion + (setq notlast (re-search-forward "^\n=" nil t))) + (or notlast + (progn + (insert "\n\n=cut") + (cperl-ensure-newlines 2) + (forward-word -2) + (if (and head1 + (not + (save-excursion + (forward-char -1) + (re-search-backward "\\(\\`\n?\\|\n\n\\)=head1\\>" + nil t)))) ; Only one + (progn + (forward-word 1) + (setq name (file-name-sans-extension + (file-name-nondirectory (buffer-file-name))) + p (point)) + (insert " NAME\n\n" name + " - \n\n=head1 SYNOPSIS\n\n\n\n" + "=head1 DESCRIPTION") + (cperl-ensure-newlines 4) + (goto-char p) + (forward-word 2) + (end-of-line) + (setq really-delete t)) + (forward-word 1)))) + (if over + (progn + (setq p (point)) + (insert "\n\n=item \n\n\n\n" + "=back") + (cperl-ensure-newlines 2) + (goto-char p) + (forward-word 1) + (end-of-line) + (setq really-delete t))) + (if (and delete really-delete) + (cperl-putback-char cperl-del-back-ch)))))) + +(defun cperl-electric-else () + "Insert a construction appropriate after a keyword. +Help message may be switched off by setting `cperl-message-electric-keyword' +to nil." + (let ((beg (save-excursion (beginning-of-line) (point)))) + (and (save-excursion + (backward-sexp 1) + (cperl-after-expr-p nil "{;:")) + (save-excursion + (not + (re-search-backward + "[#\"'`]\\|\\" + beg t))) + (save-excursion (or (not (re-search-backward "^=" nil t)) + (looking-at "=cut") + (and cperl-use-syntax-table-text-property + (not (eq (get-text-property (point) + 'syntax-type) + 'pod))))) + (progn + (cperl-indent-line) + ;;(insert " {\n\n}") + (cond + (cperl-extra-newline-before-brace + (insert "\n") + (insert "{") + (cperl-indent-line) + (insert "\n\n}")) + (t + (insert " {\n\n}"))) + (or (looking-at "[ \t]\\|$") (insert " ")) + (cperl-indent-line) + (forward-line -1) + (cperl-indent-line) + (cperl-putback-char cperl-del-back-ch) + (setq this-command 'cperl-electric-else) + (if cperl-message-electric-keyword + (message "Precede char by C-q to avoid expansion")))))) + +(defun cperl-linefeed () + "Go to end of line, open a new line and indent appropriately. +If in POD, insert appropriate lines." + (interactive) + (let ((beg (save-excursion (beginning-of-line) (point))) + (end (save-excursion (end-of-line) (point))) + (pos (point)) start over cut res) + (if (and ; Check if we need to split: + ; i.e., on a boundary and inside "{...}" + (save-excursion (cperl-to-comment-or-eol) + (>= (point) pos)) ; Not in a comment + (or (save-excursion + (skip-chars-backward " \t" beg) + (forward-char -1) + (looking-at "[;{]")) ; After { or ; + spaces + (looking-at "[ \t]*}") ; Before } + (re-search-forward "\\=[ \t]*;" end t)) ; Before spaces + ; + (save-excursion + (and + (eq (car (parse-partial-sexp pos end -1)) -1) + ; Leave the level of parens + (looking-at "[,; \t]*\\($\\|#\\)") ; Comma to allow anon subr + ; Are at end + (cperl-after-block-p (point-min)) + (progn + (backward-sexp 1) + (setq start (point-marker)) + (<= start pos))))) ; Redundant? Are after the + ; start of parens group. + (progn + (skip-chars-backward " \t") + (or (memq (preceding-char) (append ";{" nil)) + (insert ";")) + (insert "\n") + (forward-line -1) + (cperl-indent-line) + (goto-char start) + (or (looking-at "{[ \t]*$") ; If there is a statement + ; before, move it to separate line + (progn + (forward-char 1) + (insert "\n") + (cperl-indent-line))) + (forward-line 1) ; We are on the target line + (cperl-indent-line) + (beginning-of-line) + (or (looking-at "[ \t]*}[,; \t]*$") ; If there is a statement + ; after, move it to separate line + (progn + (end-of-line) + (search-backward "}" beg) + (skip-chars-backward " \t") + (or (memq (preceding-char) (append ";{" nil)) + (insert ";")) + (insert "\n") + (cperl-indent-line) + (forward-line -1))) + (forward-line -1) ; We are on the line before target + (end-of-line) + (newline-and-indent)) + (end-of-line) ; else - no splitting + (cond + ((and (looking-at "\n[ \t]*{$") + (save-excursion + (skip-chars-backward " \t") + (eq (preceding-char) ?\)))) ; Probably if () {} group + ; with an extra newline. + (forward-line 2) + (cperl-indent-line)) + ((save-excursion ; In POD header + (forward-paragraph -1) + ;; (re-search-backward "\\(\\`\n?\\|\n\n\\)=head1\\b") + ;; We are after \n now, so look for the rest + (if (looking-at "\\(\\`\n?\\|\n\\)=\\sw+") + (progn + (setq cut (looking-at "\\(\\`\n?\\|\n\\)=cut\\>")) + (setq over (looking-at "\\(\\`\n?\\|\n\\)=over\\>")) + t))) + (if (and over + (progn + (forward-paragraph -1) + (forward-word 1) + (setq pos (point)) + (setq cut (buffer-substring (point) + (save-excursion + (end-of-line) + (point)))) + (delete-char (- (save-excursion (end-of-line) (point)) + (point))) + (setq res (expand-abbrev)) + (save-excursion + (goto-char pos) + (insert cut)) + res)) + nil + (cperl-ensure-newlines (if cut 2 4)) + (forward-line 2))) + ((get-text-property (point) 'in-pod) ; In POD section + (cperl-ensure-newlines 4) + (forward-line 2)) + ((looking-at "\n[ \t]*$") ; Next line is empty - use it. + (forward-line 1) + (cperl-indent-line)) + (t + (newline-and-indent)))))) + +(defun cperl-electric-semi (arg) + "Insert character and correct line's indentation." + (interactive "P") + (if cperl-auto-newline + (cperl-electric-terminator arg) + (self-insert-command (prefix-numeric-value arg)) + (if cperl-autoindent-on-semi + (cperl-indent-line)))) + +(defun cperl-electric-terminator (arg) + "Insert character and correct line's indentation." + (interactive "P") + (let ((end (point)) + (auto (and cperl-auto-newline + (or (not (eq last-command-char ?:)) + cperl-auto-newline-after-colon))) + insertpos) + (if (and ;;(not arg) + (eolp) + (not (save-excursion + (beginning-of-line) + (skip-chars-forward " \t") + (or + ;; Ignore in comment lines + (= (following-char) ?#) + ;; Colon is special only after a label + ;; So quickly rule out most other uses of colon + ;; and do no indentation for them. + (and (eq last-command-char ?:) + (save-excursion + (forward-word 1) + (skip-chars-forward " \t") + (and (< (point) end) + (progn (goto-char (- end 1)) + (not (looking-at ":")))))) + (progn + (beginning-of-defun) + (let ((pps (parse-partial-sexp (point) end))) + (or (nth 3 pps) (nth 4 pps) (nth 5 pps)))))))) + (progn + (self-insert-command (prefix-numeric-value arg)) + ;;(forward-char -1) + (if auto (setq insertpos (point-marker))) + ;;(forward-char 1) + (cperl-indent-line) + (if auto + (progn + (newline) + (cperl-indent-line))) + (save-excursion + (if insertpos (goto-char (1- (marker-position insertpos))) + (forward-char -1)) + (delete-char 1)))) + (if insertpos + (save-excursion + (goto-char insertpos) + (self-insert-command (prefix-numeric-value arg))) + (self-insert-command (prefix-numeric-value arg))))) + +(defun cperl-electric-backspace (arg) + "Backspace, or remove the whitespace around the point inserted by an electric +key. Will untabivy if `cperl-electric-backspace-untabify' is non-nil." + (interactive "p") + (if (and cperl-auto-newline + (memq last-command '(cperl-electric-semi + cperl-electric-terminator + cperl-electric-lbrace)) + (memq (preceding-char) '(?\ ?\t ?\n))) + (let (p) + (if (eq last-command 'cperl-electric-lbrace) + (skip-chars-forward " \t\n")) + (setq p (point)) + (skip-chars-backward " \t\n") + (delete-region (point) p)) + (and (eq last-command 'cperl-electric-else) + ;; We are removing the whitespace *inside* cperl-electric-else + (setq this-command 'cperl-electric-else-really)) + (if (and cperl-auto-newline + (eq last-command 'cperl-electric-else-really) + (memq (preceding-char) '(?\ ?\t ?\n))) + (let (p) + (skip-chars-forward " \t\n") + (setq p (point)) + (skip-chars-backward " \t\n") + (delete-region (point) p)) + (if cperl-electric-backspace-untabify + (backward-delete-char-untabify arg) + (delete-backward-char arg))))) + +(defun cperl-inside-parens-p () + (condition-case () + (save-excursion + (save-restriction + (narrow-to-region (point) + (progn (beginning-of-defun) (point))) + (goto-char (point-max)) + (= (char-after (or (scan-lists (point) -1 1) (point-min))) ?\())) + (error nil))) + +(defun cperl-indent-command (&optional whole-exp) + "Indent current line as Perl code, or in some cases insert a tab character. +If `cperl-tab-always-indent' is non-nil (the default), always indent current +line. Otherwise, indent the current line only if point is at the left margin +or in the line's indentation; otherwise insert a tab. + +A numeric argument, regardless of its value, +means indent rigidly all the lines of the expression starting after point +so that this line becomes properly indented. +The relative indentation among the lines of the expression are preserved." + (interactive "P") + (cperl-update-syntaxification (point) (point)) + (if whole-exp + ;; If arg, always indent this line as Perl + ;; and shift remaining lines of expression the same amount. + (let ((shift-amt (cperl-indent-line)) + beg end) + (save-excursion + (if cperl-tab-always-indent + (beginning-of-line)) + (setq beg (point)) + (forward-sexp 1) + (setq end (point)) + (goto-char beg) + (forward-line 1) + (setq beg (point))) + (if (and shift-amt (> end beg)) + (indent-code-rigidly beg end shift-amt "#"))) + (if (and (not cperl-tab-always-indent) + (save-excursion + (skip-chars-backward " \t") + (not (bolp)))) + (insert-tab) + (cperl-indent-line)))) + +(defun cperl-indent-line (&optional parse-data) + "Indent current line as Perl code. +Return the amount the indentation changed by." + (let ((case-fold-search nil) + (pos (- (point-max) (point))) + indent i beg shift-amt) + (setq indent (cperl-calculate-indent parse-data) + i indent) + (beginning-of-line) + (setq beg (point)) + (cond ((or (eq indent nil) (eq indent t)) + (setq indent (current-indentation) i nil)) + ;;((eq indent t) ; Never? + ;; (setq indent (cperl-calculate-indent-within-comment))) + ;;((looking-at "[ \t]*#") + ;; (setq indent 0)) + (t + (skip-chars-forward " \t") + (if (listp indent) (setq indent (car indent))) + (cond ((looking-at "[A-Za-z_][A-Za-z_0-9]*:[^:]") + (and (> indent 0) + (setq indent (max cperl-min-label-indent + (+ indent cperl-label-offset))))) + ((= (following-char) ?}) + (setq indent (- indent cperl-indent-level))) + ((memq (following-char) '(?\) ?\])) ; To line up with opening paren. + (setq indent (+ indent cperl-close-paren-offset))) + ((= (following-char) ?{) + (setq indent (+ indent cperl-brace-offset)))))) + (skip-chars-forward " \t") + (setq shift-amt (and i (- indent (current-column)))) + (if (or (not shift-amt) + (zerop shift-amt)) + (if (> (- (point-max) pos) (point)) + (goto-char (- (point-max) pos))) + (delete-region beg (point)) + (indent-to indent) + ;; If initial point was within line's indentation, + ;; position after the indentation. Else stay at same point in text. + (if (> (- (point-max) pos) (point)) + (goto-char (- (point-max) pos)))) + shift-amt)) + +(defun cperl-after-label () + ;; Returns true if the point is after label. Does not do save-excursion. + (and (eq (preceding-char) ?:) + (memq (char-syntax (char-after (- (point) 2))) + '(?w ?_)) + (progn + (backward-sexp) + (looking-at "[a-zA-Z_][a-zA-Z0-9_]*:[^:]")))) + +(defun cperl-get-state (&optional parse-start start-state) + ;; returns list (START STATE DEPTH PRESTART), + ;; START is a good place to start parsing, or equal to + ;; PARSE-START if preset, + ;; STATE is what is returned by `parse-partial-sexp'. + ;; DEPTH is true is we are immediately after end of block + ;; which contains START. + ;; PRESTART is the position basing on which START was found. + (save-excursion + (let ((start-point (point)) depth state start prestart) + (if (and parse-start + (<= parse-start start-point)) + (goto-char parse-start) + (beginning-of-defun) + (setq start-state nil)) + (setq prestart (point)) + (if start-state nil + ;; Try to go out, if sub is not on the outermost level + (while (< (point) start-point) + (setq start (point) parse-start start depth nil + state (parse-partial-sexp start start-point -1)) + (if (> (car state) -1) nil + ;; The current line could start like }}}, so the indentation + ;; corresponds to a different level than what we reached + (setq depth t) + (beginning-of-line 2))) ; Go to the next line. + (if start (goto-char start))) ; Not at the start of file + (setq start (point)) + (or state (setq state (parse-partial-sexp start start-point -1 nil start-state))) + (list start state depth prestart)))) + +(defun cperl-block-p () ; Do not C-M-q ! One string contains ";" ! + ;; Positions is before ?\{. Checks whether it starts a block. + ;; No save-excursion! + (cperl-backward-to-noncomment (point-min)) + (or (memq (preceding-char) (append ";){}$@&%\C-@" nil)) ; Or label! \C-@ at bobp + ; Label may be mixed up with `$blah :' + (save-excursion (cperl-after-label)) + (and (memq (char-syntax (preceding-char)) '(?w ?_)) + (progn + (backward-sexp) + ;; Need take into account `bless', `return', `tr',... + (or (and (looking-at "[a-zA-Z0-9_:]+[ \t\n\f]*[{#]") ; Method call syntax + (not (looking-at "\\(bless\\|return\\|q[wqrx]?\\|tr\\|[smy]\\)\\>"))) + (progn + (skip-chars-backward " \t\n\f") + (and (memq (char-syntax (preceding-char)) '(?w ?_)) + (progn + (backward-sexp) + (looking-at + "sub[ \t]+[a-zA-Z0-9_:]+[ \t\n\f]*\\(([^()]*)[ \t\n\f]*\\)?[#{]"))))))))) + +(defvar cperl-look-for-prop '((pod in-pod) (here-doc-delim here-doc-group))) + +(defun cperl-calculate-indent (&optional parse-data) ; was parse-start + "Return appropriate indentation for current line as Perl code. +In usual case returns an integer: the column to indent to. +Returns nil if line starts inside a string, t if in a comment. + +Will not correct the indentation for labels, but will correct it for braces +and closing parentheses and brackets." + (cperl-update-syntaxification (point) (point)) + (save-excursion + (if (or + (and (memq (get-text-property (point) 'syntax-type) + '(pod here-doc here-doc-delim format)) + (not (get-text-property (point) 'indentable))) + ;; before start of POD - whitespace found since do not have 'pod! + (and (looking-at "[ \t]*\n=") + (error "Spaces before POD section!")) + (and (not cperl-indent-left-aligned-comments) + (looking-at "^#"))) + nil + (beginning-of-line) + (let ((indent-point (point)) + (char-after (save-excursion + (skip-chars-forward " \t") + (following-char))) + (in-pod (get-text-property (point) 'in-pod)) + (pre-indent-point (point)) + p prop look-prop is-block delim) + (cond + (in-pod + ;; In the verbatim part, probably code example. What to do??? + ) + (t + (save-excursion + ;; Not in POD + (cperl-backward-to-noncomment nil) + (setq p (max (point-min) (1- (point))) + prop (get-text-property p 'syntax-type) + look-prop (or (nth 1 (assoc prop cperl-look-for-prop)) + 'syntax-type)) + (if (memq prop '(pod here-doc format here-doc-delim)) + (progn + (goto-char (or (previous-single-property-change p look-prop) + (point-min))) + (beginning-of-line) + (setq pre-indent-point (point))))))) + (goto-char pre-indent-point) + (let* ((case-fold-search nil) + (s-s (cperl-get-state (car parse-data) (nth 1 parse-data))) + (start (or (nth 2 parse-data) + (nth 0 s-s))) + (state (nth 1 s-s)) + (containing-sexp (car (cdr state))) + old-indent) + (if (and + ;;containing-sexp ;; We are buggy at toplevel :-( + parse-data) + (progn + (setcar parse-data pre-indent-point) + (setcar (cdr parse-data) state) + (or (nth 2 parse-data) + (setcar (cddr parse-data) start)) + ;; Before this point: end of statement + (setq old-indent (nth 3 parse-data)))) + (cond ((get-text-property (point) 'indentable) + ;; indent to just after the surrounding open, + ;; skip blanks if we do not close the expression. + (goto-char (1+ (previous-single-property-change (point) 'indentable))) + (or (memq char-after (append ")]}" nil)) + (looking-at "[ \t]*\\(#\\|$\\)") + (skip-chars-forward " \t")) + (current-column)) + ((or (nth 3 state) (nth 4 state)) + ;; return nil or t if should not change this line + (nth 4 state)) + ;; XXXX Do we need to special-case this? + ((null containing-sexp) + ;; Line is at top level. May be data or function definition, + ;; or may be function argument declaration. + ;; Indent like the previous top level line + ;; unless that ends in a closeparen without semicolon, + ;; in which case this line is the first argument decl. + (skip-chars-forward " \t") + (+ (save-excursion + (goto-char start) + (- (current-indentation) + (if (nth 2 s-s) cperl-indent-level 0))) + (if (= char-after ?{) cperl-continued-brace-offset 0) + (progn + (cperl-backward-to-noncomment (or old-indent (point-min))) + ;; Look at previous line that's at column 0 + ;; to determine whether we are in top-level decls + ;; or function's arg decls. Set basic-indent accordingly. + ;; Now add a little if this is a continuation line. + (if (or (bobp) + (eq (point) old-indent) ; old-indent was at comment + (eq (preceding-char) ?\;) + ;; Had ?\) too + (and (eq (preceding-char) ?\}) + (cperl-after-block-and-statement-beg + (point-min))) ; Was start - too close + (memq char-after (append ")]}" nil)) + (and (eq (preceding-char) ?\:) ; label + (progn + (forward-sexp -1) + (skip-chars-backward " \t") + (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*[ \t]*:"))) + (get-text-property (point) 'first-format-line)) + (progn + (if (and parse-data + (not (eq char-after ?\C-j))) + (setcdr (cddr parse-data) + (list pre-indent-point))) + 0) + cperl-continued-statement-offset)))) + ((not + (or (setq is-block + (and (setq delim (= (char-after containing-sexp) ?{)) + (save-excursion ; Is it a hash? + (goto-char containing-sexp) + (cperl-block-p)))) + cperl-indent-parens-as-block)) + ;; group is an expression, not a block: + ;; indent to just after the surrounding open parens, + ;; skip blanks if we do not close the expression. + (goto-char (1+ containing-sexp)) + (or (memq char-after + (append (if delim "}" ")]}") nil)) + (looking-at "[ \t]*\\(#\\|$\\)") + (skip-chars-forward " \t")) + (+ (current-column) + (if (and delim + (eq char-after ?\})) + ;; Correct indentation of trailing ?\} + (+ cperl-indent-level cperl-close-paren-offset) + 0))) +;;; ((and (/= (char-after containing-sexp) ?{) +;;; (not cperl-indent-parens-as-block)) +;;; ;; line is expression, not statement: +;;; ;; indent to just after the surrounding open, +;;; ;; skip blanks if we do not close the expression. +;;; (goto-char (1+ containing-sexp)) +;;; (or (memq char-after (append ")]}" nil)) +;;; (looking-at "[ \t]*\\(#\\|$\\)") +;;; (skip-chars-forward " \t")) +;;; (current-column)) +;;; ((progn +;;; ;; Containing-expr starts with \{. Check whether it is a hash. +;;; (goto-char containing-sexp) +;;; (and (not (cperl-block-p)) +;;; (not cperl-indent-parens-as-block))) +;;; (goto-char (1+ containing-sexp)) +;;; (or (eq char-after ?\}) +;;; (looking-at "[ \t]*\\(#\\|$\\)") +;;; (skip-chars-forward " \t")) +;;; (+ (current-column) ; Correct indentation of trailing ?\} +;;; (if (eq char-after ?\}) (+ cperl-indent-level +;;; cperl-close-paren-offset) +;;; 0))) + (t + ;; Statement level. Is it a continuation or a new statement? + ;; Find previous non-comment character. + (goto-char pre-indent-point) + (cperl-backward-to-noncomment containing-sexp) + ;; Back up over label lines, since they don't + ;; affect whether our line is a continuation. + ;; (Had \, too) + (while ;;(or (eq (preceding-char) ?\,) + (and (eq (preceding-char) ?:) + (or ;;(eq (char-after (- (point) 2)) ?\') ; ???? + (memq (char-syntax (char-after (- (point) 2))) + '(?w ?_)))) + ;;) + (if (eq (preceding-char) ?\,) + ;; Will go to beginning of line, essentially. + ;; Will ignore embedded sexpr XXXX. + (cperl-backward-to-start-of-continued-exp containing-sexp)) + (beginning-of-line) + (cperl-backward-to-noncomment containing-sexp)) + ;; Now we get the answer. + (if (not (or (eq (1- (point)) containing-sexp) + (memq (preceding-char) + (append (if is-block " ;{" " ,;{") '(nil))) + (and (eq (preceding-char) ?\}) + (cperl-after-block-and-statement-beg + containing-sexp)) + (get-text-property (point) 'first-format-line))) + ;; This line is continuation of preceding line's statement; + ;; indent `cperl-continued-statement-offset' more than the + ;; previous line of the statement. + ;; + ;; There might be a label on this line, just + ;; consider it bad style and ignore it. + (progn + (cperl-backward-to-start-of-continued-exp containing-sexp) + (+ (if (memq char-after (append "}])" nil)) + 0 ; Closing parenth + cperl-continued-statement-offset) + (if (or is-block + (not delim) + (not (eq char-after ?\}))) + 0 + ;; Now it is a hash reference + (+ cperl-indent-level cperl-close-paren-offset)) + (if (looking-at "\\w+[ \t]*:") + (if (> (current-indentation) cperl-min-label-indent) + (- (current-indentation) cperl-label-offset) + ;; Do not move `parse-data', this should + ;; be quick anyway (this comment comes + ;; from different location): + (cperl-calculate-indent)) + (current-column)) + (if (eq char-after ?\{) + cperl-continued-brace-offset 0))) + ;; This line starts a new statement. + ;; Position following last unclosed open. + (goto-char containing-sexp) + ;; Is line first statement after an open-brace? + (or + ;; If no, find that first statement and indent like + ;; it. If the first statement begins with label, do + ;; not believe when the indentation of the label is too + ;; small. + (save-excursion + (forward-char 1) + (setq old-indent (current-indentation)) + (let ((colon-line-end 0)) + (while + (progn (skip-chars-forward " \t\n") + (looking-at "#\\|[a-zA-Z0-9_$]*:[^:]\\|=[a-zA-Z]")) + ;; Skip over comments and labels following openbrace. + (cond ((= (following-char) ?\#) + (forward-line 1)) + ((= (following-char) ?\=) + (goto-char + (or (next-single-property-change (point) 'in-pod) + (point-max)))) ; do not loop if no syntaxification + ;; label: + (t + (save-excursion (end-of-line) + (setq colon-line-end (point))) + (search-forward ":")))) + ;; The first following code counts + ;; if it is before the line we want to indent. + (and (< (point) indent-point) + (if (> colon-line-end (point)) ; After label + (if (> (current-indentation) + cperl-min-label-indent) + (- (current-indentation) cperl-label-offset) + ;; Do not believe: `max' is involved + (+ old-indent cperl-indent-level)) + (current-column))))) + ;; If no previous statement, + ;; indent it relative to line brace is on. + ;; For open brace in column zero, don't let statement + ;; start there too. If cperl-indent-level is zero, + ;; use cperl-brace-offset + cperl-continued-statement-offset instead. + ;; For open-braces not the first thing in a line, + ;; add in cperl-brace-imaginary-offset. + + ;; If first thing on a line: ????? + (+ (if (and (bolp) (zerop cperl-indent-level)) + (+ cperl-brace-offset cperl-continued-statement-offset) + cperl-indent-level) + (if (or is-block + (not delim) + (not (eq char-after ?\}))) + 0 + ;; Now it is a hash reference + (+ cperl-indent-level cperl-close-paren-offset)) + ;; Move back over whitespace before the openbrace. + ;; If openbrace is not first nonwhite thing on the line, + ;; add the cperl-brace-imaginary-offset. + (progn (skip-chars-backward " \t") + (if (bolp) 0 cperl-brace-imaginary-offset)) + ;; If the openbrace is preceded by a parenthesized exp, + ;; move to the beginning of that; + ;; possibly a different line + (progn + (if (eq (preceding-char) ?\)) + (forward-sexp -1)) + ;; In the case it starts a subroutine, indent with + ;; respect to `sub', not with respect to the + ;; first thing on the line, say in the case of + ;; anonymous sub in a hash. + ;; + (skip-chars-backward " \t") + (if (and (eq (preceding-char) ?b) + (progn + (forward-sexp -1) + (looking-at "sub\\>")) + (setq old-indent + (nth 1 + (parse-partial-sexp + (save-excursion (beginning-of-line) (point)) + (point))))) + (progn (goto-char (1+ old-indent)) + (skip-chars-forward " \t") + (current-column)) + ;; Get initial indentation of the line we are on. + ;; If line starts with label, calculate label indentation + (if (save-excursion + (beginning-of-line) + (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]")) + (if (> (current-indentation) cperl-min-label-indent) + (- (current-indentation) cperl-label-offset) + ;; Do not move `parse-data', this should + ;; be quick anyway: + (cperl-calculate-indent)) + (current-indentation)))))))))))))) + +(defvar cperl-indent-alist + '((string nil) + (comment nil) + (toplevel 0) + (toplevel-after-parenth 2) + (toplevel-continued 2) + (expression 1)) + "Alist of indentation rules for CPerl mode. +The values mean: + nil: do not indent; + number: add this amount of indentation. + +Not finished, not used.") + +(defun cperl-where-am-i (&optional parse-start start-state) + ;; Unfinished + "Return a list of lists ((TYPE POS)...) of good points before the point. +POS may be nil if it is hard to find, say, when TYPE is `string' or `comment'. + +Not finished, not used." + (save-excursion + (let* ((start-point (point)) + (s-s (cperl-get-state)) + (start (nth 0 s-s)) + (state (nth 1 s-s)) + (prestart (nth 3 s-s)) + (containing-sexp (car (cdr state))) + (case-fold-search nil) + (res (list (list 'parse-start start) (list 'parse-prestart prestart)))) + (cond ((nth 3 state) ; In string + (setq res (cons (list 'string nil (nth 3 state)) res))) ; What started string + ((nth 4 state) ; In comment + (setq res (cons '(comment) res))) + ((null containing-sexp) + ;; Line is at top level. + ;; Indent like the previous top level line + ;; unless that ends in a closeparen without semicolon, + ;; in which case this line is the first argument decl. + (cperl-backward-to-noncomment (or parse-start (point-min))) + ;;(skip-chars-backward " \t\f\n") + (cond + ((or (bobp) + (memq (preceding-char) (append ";}" nil))) + (setq res (cons (list 'toplevel start) res))) + ((eq (preceding-char) ?\) ) + (setq res (cons (list 'toplevel-after-parenth start) res))) + (t + (setq res (cons (list 'toplevel-continued start) res))))) + ((/= (char-after containing-sexp) ?{) + ;; line is expression, not statement: + ;; indent to just after the surrounding open. + ;; skip blanks if we do not close the expression. + (setq res (cons (list 'expression-blanks + (progn + (goto-char (1+ containing-sexp)) + (or (looking-at "[ \t]*\\(#\\|$\\)") + (skip-chars-forward " \t")) + (point))) + (cons (list 'expression containing-sexp) res)))) + ((progn + ;; Containing-expr starts with \{. Check whether it is a hash. + (goto-char containing-sexp) + (not (cperl-block-p))) + (setq res (cons (list 'expression-blanks + (progn + (goto-char (1+ containing-sexp)) + (or (looking-at "[ \t]*\\(#\\|$\\)") + (skip-chars-forward " \t")) + (point))) + (cons (list 'expression containing-sexp) res)))) + (t + ;; Statement level. + (setq res (cons (list 'in-block containing-sexp) res)) + ;; Is it a continuation or a new statement? + ;; Find previous non-comment character. + (cperl-backward-to-noncomment containing-sexp) + ;; Back up over label lines, since they don't + ;; affect whether our line is a continuation. + ;; Back up comma-delimited lines too ????? + (while (or (eq (preceding-char) ?\,) + (save-excursion (cperl-after-label))) + (if (eq (preceding-char) ?\,) + ;; Will go to beginning of line, essentially + ;; Will ignore embedded sexpr XXXX. + (cperl-backward-to-start-of-continued-exp containing-sexp)) + (beginning-of-line) + (cperl-backward-to-noncomment containing-sexp)) + ;; Now we get the answer. + (if (not (memq (preceding-char) (append ";}{" '(nil)))) ; Was ?\, + ;; This line is continuation of preceding line's statement. + (list (list 'statement-continued containing-sexp)) + ;; This line starts a new statement. + ;; Position following last unclosed open. + (goto-char containing-sexp) + ;; Is line first statement after an open-brace? + (or + ;; If no, find that first statement and indent like + ;; it. If the first statement begins with label, do + ;; not believe when the indentation of the label is too + ;; small. + (save-excursion + (forward-char 1) + (let ((colon-line-end 0)) + (while (progn (skip-chars-forward " \t\n" start-point) + (and (< (point) start-point) + (looking-at + "#\\|[a-zA-Z_][a-zA-Z0-9_]*:[^:]"))) + ;; Skip over comments and labels following openbrace. + (cond ((= (following-char) ?\#) + ;;(forward-line 1) + (end-of-line)) + ;; label: + (t + (save-excursion (end-of-line) + (setq colon-line-end (point))) + (search-forward ":")))) + ;; Now at the point, after label, or at start + ;; of first statement in the block. + (and (< (point) start-point) + (if (> colon-line-end (point)) + ;; Before statement after label + (if (> (current-indentation) + cperl-min-label-indent) + (list (list 'label-in-block (point))) + ;; Do not believe: `max' is involved + (list + (list 'label-in-block-min-indent (point)))) + ;; Before statement + (list 'statement-in-block (point)))))) + ;; If no previous statement, + ;; indent it relative to line brace is on. + ;; For open brace in column zero, don't let statement + ;; start there too. If cperl-indent-level is zero, + ;; use cperl-brace-offset + cperl-continued-statement-offset instead. + ;; For open-braces not the first thing in a line, + ;; add in cperl-brace-imaginary-offset. + + ;; If first thing on a line: ????? + (+ (if (and (bolp) (zerop cperl-indent-level)) + (+ cperl-brace-offset cperl-continued-statement-offset) + cperl-indent-level) + ;; Move back over whitespace before the openbrace. + ;; If openbrace is not first nonwhite thing on the line, + ;; add the cperl-brace-imaginary-offset. + (progn (skip-chars-backward " \t") + (if (bolp) 0 cperl-brace-imaginary-offset)) + ;; If the openbrace is preceded by a parenthesized exp, + ;; move to the beginning of that; + ;; possibly a different line + (progn + (if (eq (preceding-char) ?\)) + (forward-sexp -1)) + ;; Get initial indentation of the line we are on. + ;; If line starts with label, calculate label indentation + (if (save-excursion + (beginning-of-line) + (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]")) + (if (> (current-indentation) cperl-min-label-indent) + (- (current-indentation) cperl-label-offset) + (cperl-calculate-indent)) + (current-indentation)))))))) + res))) + +(defun cperl-calculate-indent-within-comment () + "Return the indentation amount for line, assuming that +the current line is to be regarded as part of a block comment." + (let (end star-start) + (save-excursion + (beginning-of-line) + (skip-chars-forward " \t") + (setq end (point)) + (and (= (following-char) ?#) + (forward-line -1) + (cperl-to-comment-or-eol) + (setq end (point))) + (goto-char end) + (current-column)))) + + +(defun cperl-to-comment-or-eol () + "Go to position before comment on the current line, or to end of line. +Returns true if comment is found." + (let (state stop-in cpoint (lim (progn (end-of-line) (point)))) + (beginning-of-line) + (if (or + (eq (get-text-property (point) 'syntax-type) 'pod) + (re-search-forward "\\=[ \t]*\\(#\\|$\\)" lim t)) + (if (eq (preceding-char) ?\#) (progn (backward-char 1) t)) + ;; Else + (while (not stop-in) + (setq state (parse-partial-sexp (point) lim nil nil nil t)) + ; stop at comment + ;; If fails (beginning-of-line inside sexp), then contains not-comment + (if (nth 4 state) ; After `#'; + ; (nth 2 state) can be + ; beginning of m,s,qq and so + ; on + (if (nth 2 state) + (progn + (setq cpoint (point)) + (goto-char (nth 2 state)) + (cond + ((looking-at "\\(s\\|tr\\)\\>") + (or (re-search-forward + "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*" + lim 'move) + (setq stop-in t))) + ((looking-at "\\(m\\|q\\([qxwr]\\)?\\)\\>") + (or (re-search-forward + "\\=\\w+[ \t]*#\\([^\n\\\\#]\\|\\\\[\\\\#]\\)*#" + lim 'move) + (setq stop-in t))) + (t ; It was fair comment + (setq stop-in t) ; Finish + (goto-char (1- cpoint))))) + (setq stop-in t) ; Finish + (forward-char -1)) + (setq stop-in t))) ; Finish + (nth 4 state)))) + +(defsubst cperl-1- (p) + (max (point-min) (1- p))) + +(defsubst cperl-1+ (p) + (min (point-max) (1+ p))) + +(defsubst cperl-modify-syntax-type (at how) + (if (< at (point-max)) + (progn + (put-text-property at (1+ at) 'syntax-table how) + (put-text-property at (1+ at) 'rear-nonsticky t)))) + +(defun cperl-protect-defun-start (s e) + ;; C code looks for "^\\s(" to skip comment backward in "hard" situations + (save-excursion + (goto-char s) + (while (re-search-forward "^\\s(" e 'to-end) + (put-text-property (1- (point)) (point) 'syntax-table cperl-st-punct)))) + +(defun cperl-commentify (bb e string &optional noface) + (if cperl-use-syntax-table-text-property + (if (eq noface 'n) ; Only immediate + nil + ;; We suppose that e is _after_ the end of construction, as after eol. + (setq string (if string cperl-st-sfence cperl-st-cfence)) + (if (> bb (- e 2)) + ;; one-char string/comment?! + (cperl-modify-syntax-type bb cperl-st-punct) + (cperl-modify-syntax-type bb string) + (cperl-modify-syntax-type (1- e) string)) + (if (and (eq string cperl-st-sfence) (> (- e 2) bb)) + (put-text-property (1+ bb) (1- e) + 'syntax-table cperl-string-syntax-table)) + (cperl-protect-defun-start bb e)) + ;; Fontify + (or noface + (not cperl-pod-here-fontify) + (put-text-property bb e 'face (if string 'font-lock-string-face + 'font-lock-comment-face))))) + +(defvar cperl-starters '(( ?\( . ?\) ) + ( ?\[ . ?\] ) + ( ?\{ . ?\} ) + ( ?\< . ?\> ))) + +(defun cperl-forward-re (lim end is-2arg set-st st-l err-l argument + &optional ostart oend) + ;; Works *before* syntax recognition is done + ;; May modify syntax-type text property if the situation is too hard + (let (b starter ender st i i2 go-forward reset-st) + (skip-chars-forward " \t") + ;; ender means matching-char matcher. + (setq b (point) + starter (if (eobp) 0 (char-after b)) + ender (cdr (assoc starter cperl-starters))) + ;; What if starter == ?\\ ???? + (if set-st + (if (car st-l) + (setq st (car st-l)) + (setcar st-l (make-syntax-table)) + (setq i 0 st (car st-l)) + (while (< i 256) + (modify-syntax-entry i "." st) + (setq i (1+ i))) + (modify-syntax-entry ?\\ "\\" st))) + (setq set-st t) + ;; Whether we have an intermediate point + (setq i nil) + ;; Prepare the syntax table: + (and set-st + (if (not ender) ; m/blah/, s/x//, s/x/y/ + (modify-syntax-entry starter "$" st) + (modify-syntax-entry starter (concat "(" (list ender)) st) + (modify-syntax-entry ender (concat ")" (list starter)) st))) + (condition-case bb + (progn + ;; We use `$' syntax class to find matching stuff, but $$ + ;; is recognized the same as $, so we need to check this manually. + (if (and (eq starter (char-after (cperl-1+ b))) + (not ender)) + ;; $ has TeXish matching rules, so $$ equiv $... + (forward-char 2) + (setq reset-st (syntax-table)) + (set-syntax-table st) + (forward-sexp 1) + (if (<= (point) (1+ b)) + (error "Unfinished regular expression")) + (set-syntax-table reset-st) + (setq reset-st nil) + ;; Now the problem is with m;blah;; + (and (not ender) + (eq (preceding-char) + (char-after (- (point) 2))) + (save-excursion + (forward-char -2) + (= 0 (% (skip-chars-backward "\\\\") 2))) + (forward-char -1))) + ;; Now we are after the first part. + (and is-2arg ; Have trailing part + (not ender) + (eq (following-char) starter) ; Empty trailing part + (progn + (or (eq (char-syntax (following-char)) ?.) + ;; Make trailing letter into punctuation + (cperl-modify-syntax-type (point) cperl-st-punct)) + (setq is-2arg nil go-forward t))) ; Ignore the tail + (if is-2arg ; Not number => have second part + (progn + (setq i (point) i2 i) + (if ender + (if (memq (following-char) '(?\ ?\t ?\n ?\f)) + (progn + (if (looking-at "[ \t\n\f]+\\(#[^\n]*\n[ \t\n\f]*\\)+") + (goto-char (match-end 0)) + (skip-chars-forward " \t\n\f")) + (setq i2 (point)))) + (forward-char -1)) + (modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st) + (if ender (modify-syntax-entry ender "." st)) + (setq set-st nil) + (setq ender (cperl-forward-re lim end nil t st-l err-l + argument starter ender) + ender (nth 2 ender))))) + (error (goto-char lim) + (setq set-st nil) + (if reset-st + (set-syntax-table reset-st)) + (or end + (message + "End of `%s%s%c ... %c' string/RE not found: %s" + argument + (if ostart (format "%c ... %c" ostart (or oend ostart)) "") + starter (or ender starter) bb) + (or (car err-l) (setcar err-l b))))) + (if set-st + (progn + (modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st) + (if ender (modify-syntax-entry ender "." st)))) + ;; i: have 2 args, after end of the first arg + ;; i2: start of the second arg, if any (before delim iff `ender'). + ;; ender: the last arg bounded by parens-like chars, the second one of them + ;; starter: the starting delimiter of the first arg + ;; go-forward: has 2 args, and the second part is empty + (list i i2 ender starter go-forward))) + +(defvar font-lock-string-face) +;;(defvar font-lock-reference-face) +(defvar font-lock-constant-face) +(defsubst cperl-postpone-fontification (b e type val &optional now) + ;; Do after syntactic fontification? + (if cperl-syntaxify-by-font-lock + (or now (put-text-property b e 'cperl-postpone (cons type val))) + (put-text-property b e type val))) + +;;; Here is how the global structures (those which cannot be +;;; recognized locally) are marked: +;; a) PODs: +;; Start-to-end is marked `in-pod' ==> t +;; Each non-literal part is marked `syntax-type' ==> `pod' +;; Each literal part is marked `syntax-type' ==> `in-pod' +;; b) HEREs: +;; Start-to-end is marked `here-doc-group' ==> t +;; The body is marked `syntax-type' ==> `here-doc' +;; The delimiter is marked `syntax-type' ==> `here-doc-delim' +;; c) FORMATs: +;; First line (to =) marked `first-format-line' ==> t +;; After-this--to-end is marked `syntax-type' ==> `format' +;; d) 'Q'uoted string: +;; part between markers inclusive is marked `syntax-type' ==> `string' +;; part between `q' and the first marker is marked `syntax-type' ==> `prestring' + +(defun cperl-unwind-to-safe (before &optional end) + ;; if BEFORE, go to the previous start-of-line on each step of unwinding + (let ((pos (point)) opos) + (setq opos pos) + (while (and pos (get-text-property pos 'syntax-type)) + (setq pos (previous-single-property-change pos 'syntax-type)) + (if pos + (if before + (progn + (goto-char (cperl-1- pos)) + (beginning-of-line) + (setq pos (point))) + (goto-char (setq pos (cperl-1- pos)))) + ;; Up to the start + (goto-char (point-min)))) + ;; Skip empty lines + (and (looking-at "\n*=") + (/= 0 (skip-chars-backward "\n")) + (forward-char)) + (setq pos (point)) + (if end + ;; Do the same for end, going small steps + (progn + (while (and end (get-text-property end 'syntax-type)) + (setq pos end + end (next-single-property-change end 'syntax-type))) + (or end pos))))) + +(defvar cperl-nonoverridable-face) +(defvar font-lock-function-name-face) +(defvar font-lock-comment-face) + +(defun cperl-find-pods-heres (&optional min max non-inter end ignore-max) + "Scans the buffer for hard-to-parse Perl constructions. +If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify +the sections using `cperl-pod-head-face', `cperl-pod-face', +`cperl-here-face'." + (interactive) + (or min (setq min (point-min) + cperl-syntax-state nil + cperl-syntax-done-to min)) + (or max (setq max (point-max))) + (let* ((cperl-pod-here-fontify (eval cperl-pod-here-fontify)) go tmpend + face head-face here-face b e bb tag qtag b1 e1 argument i c tail tb + is-REx is-x-REx REx-comment-start REx-comment-end was-comment i2 + (case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t) + (modified (buffer-modified-p)) + (after-change-functions nil) + (use-syntax-state (and cperl-syntax-state + (>= min (car cperl-syntax-state)))) + (state-point (if use-syntax-state + (car cperl-syntax-state) + (point-min))) + (state (if use-syntax-state + (cdr cperl-syntax-state))) + ;; (st-l '(nil)) (err-l '(nil)) ; Would overwrite - propagates from a function call to a function call! + (st-l (list nil)) (err-l (list nil)) + ;; Somehow font-lock may be not loaded yet... + (font-lock-string-face (if (boundp 'font-lock-string-face) + font-lock-string-face + 'font-lock-string-face)) + (font-lock-constant-face (if (boundp 'font-lock-constant-face) + font-lock-constant-face + 'font-lock-constant-face)) + (font-lock-function-name-face + (if (boundp 'font-lock-function-name-face) + font-lock-function-name-face + 'font-lock-function-name-face)) + (font-lock-comment-face + (if (boundp 'font-lock-comment-face) + font-lock-comment-face + 'font-lock-comment-face)) + (cperl-nonoverridable-face + (if (boundp 'cperl-nonoverridable-face) + cperl-nonoverridable-face + 'cperl-nonoverridable-face)) + (stop-point (if ignore-max + (point-max) + max)) + (search + (concat + "\\(\\`\n?\\|^\n\\)=" + "\\|" + ;; One extra () before this: + "<<" + "\\(" ; 1 + 1 + ;; First variant "BLAH" or just ``. + "[ \t]*" ; Yes, whitespace is allowed! + "\\([\"'`]\\)" ; 2 + 1 = 3 + "\\([^\"'`\n]*\\)" ; 3 + 1 + "\\3" + "\\|" + ;; Second variant: Identifier or \ID (same as 'ID') or empty + "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 4 + 1, 5 + 1 + ;; Do not have <<= or << 30 or <<30 or << $blah. + ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1 + "\\(\\)" ; To preserve count of pars :-( 6 + 1 + "\\)" + "\\|" + ;; 1+6 extra () before this: + "^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$" + (if cperl-use-syntax-table-text-property + (concat + "\\|" + ;; 1+6+2=9 extra () before this: + "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>" + "\\|" + ;; 1+6+2+1=10 extra () before this: + "\\([?/<]\\)" ; /blah/ or ?blah? or + "\\|" + ;; 1+6+2+1+1=11 extra () before this: + "\\[ \t]*\\([a-zA-Z_:'0-9]+[ \t]*\\)?\\(([^()]*)\\)" + "\\|" + ;; 1+6+2+1+1+2=13 extra () before this: + "\\$\\(['{]\\)" + "\\|" + ;; 1+6+2+1+1+2+1=14 extra () before this: + "\\(\\") + (if ignore-max + nil ; Doing a chunk only + (message "=cut is not preceded by a POD section") + (or (car err-l) (setcar err-l (point)))) + (beginning-of-line) + + (setq b (point) + bb b + tb (match-beginning 0) + b1 nil) ; error condition + ;; We do not search to max, since we may be called from + ;; some hook of fontification, and max is random + (or (re-search-forward "^\n=cut\\>" stop-point 'toend) + (progn + (goto-char b) + (if (re-search-forward "\n=cut\\>" stop-point 'toend) + (progn + (message "=cut is not preceded by an empty line") + (setq b1 t) + (or (car err-l) (setcar err-l b)))))) + (beginning-of-line 2) ; An empty line after =cut is not POD! + (setq e (point)) + (and (> e max) + (progn + (remove-text-properties + max e '(syntax-type t in-pod t syntax-table t + cperl-postpone t + syntax-subtype t + here-doc-group t + rear-nonsticky t + first-format-line t + indentable t)) + (setq tmpend tb))) + (put-text-property b e 'in-pod t) + (put-text-property b e 'syntax-type 'in-pod) + (goto-char b) + (while (re-search-forward "\n\n[ \t]" e t) + ;; We start 'pod 1 char earlier to include the preceding line + (beginning-of-line) + (put-text-property (cperl-1- b) (point) 'syntax-type 'pod) + (cperl-put-do-not-fontify b (point) t) + ;; mark the non-literal parts as PODs + (if cperl-pod-here-fontify + (cperl-postpone-fontification b (point) 'face face t)) + (re-search-forward "\n\n[^ \t\f\n]" e 'toend) + (beginning-of-line) + (setq b (point))) + (put-text-property (cperl-1- (point)) e 'syntax-type 'pod) + (cperl-put-do-not-fontify (point) e t) + (if cperl-pod-here-fontify + (progn + ;; mark the non-literal parts as PODs + (cperl-postpone-fontification (point) e 'face face t) + (goto-char bb) + (if (looking-at + "=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$") + ;; mark the headers + (cperl-postpone-fontification + (match-beginning 1) (match-end 1) + 'face head-face)) + (while (re-search-forward + ;; One paragraph + "^\n=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$" + e 'toend) + ;; mark the headers + (cperl-postpone-fontification + (match-beginning 1) (match-end 1) + 'face head-face)))) + (cperl-commentify bb e nil) + (goto-char e) + (or (eq e (point-max)) + (forward-char -1)))) ; Prepare for immediate POD start. + ;; Here document + ;; We do only one here-per-line + ;; ;; One extra () before this: + ;;"<<" + ;; "\\(" ; 1 + 1 + ;; ;; First variant "BLAH" or just ``. + ;; "[ \t]*" ; Yes, whitespace is allowed! + ;; "\\([\"'`]\\)" ; 2 + 1 + ;; "\\([^\"'`\n]*\\)" ; 3 + 1 + ;; "\\3" + ;; "\\|" + ;; ;; Second variant: Identifier or \ID or empty + ;; "\\\\?\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)" ; 4 + 1, 5 + 1 + ;; ;; Do not have <<= or << 30 or <<30 or << $blah. + ;; ;; "\\([^= \t0-9$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)" ; 6 + 1 + ;; "\\(\\)" ; To preserve count of pars :-( 6 + 1 + ;; "\\)" + ((match-beginning 2) ; 1 + 1 + ;; Abort in comment: + (setq b (point)) + (setq state (parse-partial-sexp state-point b nil nil state) + state-point b + tb (match-beginning 0) + i (or (nth 3 state) (nth 4 state))) + (if i + (setq c t) + (setq c (and + (match-beginning 5) + (not (match-beginning 6)) ; Empty + (looking-at + "[ \t]*[=0-9$@%&(]")))) + (if c ; Not here-doc + nil ; Skip it. + (if (match-beginning 5) ;4 + 1 + (setq b1 (match-beginning 5) ; 4 + 1 + e1 (match-end 5)) ; 4 + 1 + (setq b1 (match-beginning 4) ; 3 + 1 + e1 (match-end 4))) ; 3 + 1 + (setq tag (buffer-substring b1 e1) + qtag (regexp-quote tag)) + (cond (cperl-pod-here-fontify + ;; Highlight the starting delimiter + (cperl-postpone-fontification b1 e1 'face font-lock-constant-face) + (cperl-put-do-not-fontify b1 e1 t))) + (forward-line) + (setq b (point)) + ;; We do not search to max, since we may be called from + ;; some hook of fontification, and max is random + (or (and (re-search-forward (concat "^" qtag "$") + stop-point 'toend) + (eq (following-char) ?\n)) + (progn ; Pretend we matched at the end + (goto-char (point-max)) + (re-search-forward "\\'") + (message "End of here-document `%s' not found." tag) + (or (car err-l) (setcar err-l b)))) + (if cperl-pod-here-fontify + (progn + ;; Highlight the ending delimiter + (cperl-postpone-fontification (match-beginning 0) (match-end 0) + 'face font-lock-constant-face) + (cperl-put-do-not-fontify b (match-end 0) t) + ;; Highlight the HERE-DOC + (cperl-postpone-fontification b (match-beginning 0) + 'face here-face))) + (setq e1 (cperl-1+ (match-end 0))) + (put-text-property b (match-beginning 0) + 'syntax-type 'here-doc) + (put-text-property (match-beginning 0) e1 + 'syntax-type 'here-doc-delim) + (put-text-property b e1 + 'here-doc-group t) + (cperl-commentify b e1 nil) + (cperl-put-do-not-fontify b (match-end 0) t) + (if (> e1 max) + (setq tmpend tb)))) + ;; format + ((match-beginning 8) + ;; 1+6=7 extra () before this: + ;;"^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$" + (setq b (point) + name (if (match-beginning 8) ; 7 + 1 + (buffer-substring (match-beginning 8) ; 7 + 1 + (match-end 8)) ; 7 + 1 + "") + tb (match-beginning 0)) + (setq argument nil) + (put-text-property (save-excursion + (beginning-of-line) + (point)) + b 'first-format-line 't) + (if cperl-pod-here-fontify + (while (and (eq (forward-line) 0) + (not (looking-at "^[.;]$"))) + (cond + ((looking-at "^#")) ; Skip comments + ((and argument ; Skip argument multi-lines + (looking-at "^[ \t]*{")) + (forward-sexp 1) + (setq argument nil)) + (argument ; Skip argument lines + (setq argument nil)) + (t ; Format line + (setq b1 (point)) + (setq argument (looking-at "^[^\n]*[@^]")) + (end-of-line) + ;; Highlight the format line + (cperl-postpone-fontification b1 (point) + 'face font-lock-string-face) + (cperl-commentify b1 (point) nil) + (cperl-put-do-not-fontify b1 (point) t)))) + ;; We do not search to max, since we may be called from + ;; some hook of fontification, and max is random + (re-search-forward "^[.;]$" stop-point 'toend)) + (beginning-of-line) + (if (looking-at "^\\.$") ; ";" is not supported yet + (progn + ;; Highlight the ending delimiter + (cperl-postpone-fontification (point) (+ (point) 2) + 'face font-lock-string-face) + (cperl-commentify (point) (+ (point) 2) nil) + (cperl-put-do-not-fontify (point) (+ (point) 2) t)) + (message "End of format `%s' not found." name) + (or (car err-l) (setcar err-l b))) + (forward-line) + (if (> (point) max) + (setq tmpend tb)) + (put-text-property b (point) 'syntax-type 'format)) + ;; Regexp: + ((or (match-beginning 10) (match-beginning 11)) + ;; 1+6+2=9 extra () before this: + ;; "\\<\\(q[wxqr]?\\|[msy]\\|tr\\)\\>" + ;; "\\|" + ;; "\\([?/<]\\)" ; /blah/ or ?blah? or + (setq b1 (if (match-beginning 10) 10 11) + argument (buffer-substring + (match-beginning b1) (match-end b1)) + b (point) + i b + c (char-after (match-beginning b1)) + bb (char-after (1- (match-beginning b1))) ; tmp holder + ;; bb == "Not a stringy" + bb (if (eq b1 10) ; user variables/whatever + (and (memq bb (append "$@%*#_:-&>" nil)) ; $#y) + (cond ((eq bb ?-) (eq c ?s)) ; -s file test + ((eq bb ?\:) ; $opt::s + (eq (char-after + (- (match-beginning b1) 2)) + ?\:)) + ((eq bb ?\>) ; $foo->s + (eq (char-after + (- (match-beginning b1) 2)) + ?\-)) + ((eq bb ?\&) + (not (eq (char-after ; &&m/blah/ + (- (match-beginning b1) 2)) + ?\&))) + (t t))) + ;; or <$file> + (and (eq c ?\<) + ;; Do not stringify , <$fh> : + (save-match-data + (looking-at + "\\$?\\([_a-zA-Z:][_a-zA-Z0-9:]*\\)?>")))) + tb (match-beginning 0)) + (goto-char (match-beginning b1)) + (cperl-backward-to-noncomment (point-min)) + (or bb + (if (eq b1 11) ; bare /blah/ or ?blah? or + (setq argument "" + b1 nil + bb ; Not a regexp? + (progn + (not + ;; What is below: regexp-p? + (and + (or (memq (preceding-char) + (append (if (memq c '(?\? ?\<)) + ;; $a++ ? 1 : 2 + "~{(=|&*!,;:" + "~{(=|&+-*!,;:") nil)) + (and (eq (preceding-char) ?\}) + (cperl-after-block-p (point-min))) + (and (eq (char-syntax (preceding-char)) ?w) + (progn + (forward-sexp -1) +;;; After these keywords `/' starts a RE. One should add all the +;;; functions/builtins which expect an argument, but ... + (if (eq (preceding-char) ?-) + ;; -d ?foo? is a RE + (looking-at "[a-zA-Z]\\>") + (and + (not (memq (preceding-char) + '(?$ ?@ ?& ?%))) + (looking-at + "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\)\\>"))))) + (and (eq (preceding-char) ?.) + (eq (char-after (- (point) 2)) ?.)) + (bobp)) + ;; m|blah| ? foo : bar; + (not + (and (eq c ?\?) + cperl-use-syntax-table-text-property + (not (bobp)) + (progn + (forward-char -1) + (looking-at "\\s|"))))))) + b (1- b)) + ;; s y tr m + ;; Check for $a -> y + (setq b1 (preceding-char) + go (point)) + (if (and (eq b1 ?>) + (eq (char-after (- go 2)) ?-)) + ;; Not a regexp + (setq bb t)))) + (or bb (setq state (parse-partial-sexp + state-point b nil nil state) + state-point b)) + (setq bb (or bb (nth 3 state) (nth 4 state))) + (goto-char b) + (or bb + (progn + (if (looking-at "[ \t\n\f]+\\(#[^\n]*\n[ \t\n\f]*\\)+") + (goto-char (match-end 0)) + (skip-chars-forward " \t\n\f")) + (cond ((and (eq (following-char) ?\}) + (eq b1 ?\{)) + ;; Check for $a[23]->{ s }, @{s} and *{s::foo} + (goto-char (1- go)) + (skip-chars-backward " \t\n\f") + (if (memq (preceding-char) (append "$@%&*" nil)) + (setq bb t) ; @{y} + (condition-case nil + (forward-sexp -1) + (error nil))) + (if (or bb + (looking-at ; $foo -> {s} + "[$@]\\$*\\([a-zA-Z0-9_:]+\\|[^{]\\)\\([ \t\n]*->\\)?[ \t\n]*{") + (and ; $foo[12] -> {s} + (memq (following-char) '(?\{ ?\[)) + (progn + (forward-sexp 1) + (looking-at "\\([ \t\n]*->\\)?[ \t\n]*{")))) + (setq bb t) + (goto-char b))) + ((and (eq (following-char) ?=) + (eq (char-after (1+ (point))) ?\>)) + ;; Check for { foo => 1, s => 2 } + ;; Apparently s=> is never a substitution... + (setq bb t)) + ((and (eq (following-char) ?:) + (eq b1 ?\{) ; Check for $ { s::bar } + (looking-at "::[a-zA-Z0-9_:]*[ \t\n\f]*}") + (progn + (goto-char (1- go)) + (skip-chars-backward " \t\n\f") + (memq (preceding-char) + (append "$@%&*" nil)))) + (setq bb t))))) + (if bb + (goto-char i) + ;; Skip whitespace and comments... + (if (looking-at "[ \t\n\f]+\\(#[^\n]*\n[ \t\n\f]*\\)+") + (goto-char (match-end 0)) + (skip-chars-forward " \t\n\f")) + (if (> (point) b) + (put-text-property b (point) 'syntax-type 'prestring)) + ;; qtag means two-arg matcher, may be reset to + ;; 2 or 3 later if some special quoting is needed. + ;; e1 means matching-char matcher. + (setq b (point) + ;; has 2 args + i2 (string-match "^\\([sy]\\|tr\\)$" argument) + ;; We do not search to max, since we may be called from + ;; some hook of fontification, and max is random + i (cperl-forward-re stop-point end + i2 + t st-l err-l argument) + ;; Note that if `go', then it is considered as 1-arg + b1 (nth 1 i) ; start of the second part + tag (nth 2 i) ; ender-char, true if second part + ; is with matching chars [] + go (nth 4 i) ; There is a 1-char part after the end + i (car i) ; intermediate point + e1 (point) ; end + ;; Before end of the second part if non-matching: /// + tail (if (and i (not tag)) + (1- e1)) + e (if i i e1) ; end of the first part + qtag nil ; need to preserve backslashitis + is-x-REx nil) ; REx has //x modifier + ;; Commenting \\ is dangerous, what about ( ? + (and i tail + (eq (char-after i) ?\\) + (setq qtag t)) + (if (looking-at "\\sw*x") ; qr//x + (setq is-x-REx t)) + (if (null i) + ;; Considered as 1arg form + (progn + (cperl-commentify b (point) t) + (put-text-property b (point) 'syntax-type 'string) + (if (or is-x-REx + ;; ignore other text properties: + (string-match "^qw$" argument)) + (put-text-property b (point) 'indentable t)) + (and go + (setq e1 (cperl-1+ e1)) + (or (eobp) + (forward-char 1)))) + (cperl-commentify b i t) + (if (looking-at "\\sw*e") ; s///e + (progn + (and + ;; silent: + (cperl-find-pods-heres b1 (1- (point)) t end) + ;; Error + (goto-char (1+ max))) + (if (and tag (eq (preceding-char) ?\>)) + (progn + (cperl-modify-syntax-type (1- (point)) cperl-st-ket) + (cperl-modify-syntax-type i cperl-st-bra))) + (put-text-property b i 'syntax-type 'string) + (if is-x-REx + (put-text-property b i 'indentable t))) + (cperl-commentify b1 (point) t) + (put-text-property b (point) 'syntax-type 'string) + (if is-x-REx + (put-text-property b i 'indentable t)) + (if qtag + (cperl-modify-syntax-type (1+ i) cperl-st-punct)) + (setq tail nil))) + ;; Now: tail: if the second part is non-matching without ///e + (if (eq (char-syntax (following-char)) ?w) + (progn + (forward-word 1) ; skip modifiers s///s + (if tail (cperl-commentify tail (point) t)) + (cperl-postpone-fontification + e1 (point) 'face 'cperl-nonoverridable-face))) + ;; Check whether it is m// which means "previous match" + ;; and highlight differently + (setq is-REx + (and (string-match "^\\([sm]?\\|qr\\)$" argument) + (or (not (= (length argument) 0)) + (not (eq c ?\<))))) + (if (and is-REx + (eq e (+ 2 b)) + ;; split // *is* using zero-pattern + (save-excursion + (condition-case nil + (progn + (goto-char tb) + (forward-sexp -1) + (not (looking-at "split\\>"))) + (error t)))) + (cperl-postpone-fontification + b e 'face font-lock-function-name-face) + (if (or i2 ; Has 2 args + (and cperl-fontify-m-as-s + (or + (string-match "^\\(m\\|qr\\)$" argument) + (and (eq 0 (length argument)) + (not (eq ?\< (char-after b))))))) + (progn + (cperl-postpone-fontification + b (cperl-1+ b) 'face font-lock-constant-face) + (cperl-postpone-fontification + (1- e) e 'face font-lock-constant-face))) + (if (and is-REx cperl-regexp-scan) + ;; Process RExen better + (save-excursion + (goto-char (1+ b)) + (while + (and (< (point) e) + (re-search-forward + (if is-x-REx + (if (eq (char-after b) ?\#) + "\\((\\?\\\\#\\)\\|\\(\\\\#\\)" + "\\((\\?#\\)\\|\\(#\\)") + (if (eq (char-after b) ?\#) + "\\((\\?\\\\#\\)" + "\\((\\?#\\)")) + (1- e) 'to-end)) + (goto-char (match-beginning 0)) + (setq REx-comment-start (point) + was-comment t) + (if (save-excursion + (and + ;; XXX not working if outside delimiter is # + (eq (preceding-char) ?\\) + (= (% (skip-chars-backward "$\\\\") 2) -1))) + ;; Not a comment, avoid loop: + (progn (setq was-comment nil) + (forward-char 1)) + (if (match-beginning 2) + (progn + (beginning-of-line 2) + (if (> (point) e) + (goto-char (1- e)))) + ;; Works also if the outside delimiters are (). + (or (search-forward ")" (1- e) 'toend) + (message + "Couldn't find end of (?#...)-comment in a REx, pos=%s" + REx-comment-start)))) + (if (>= (point) e) + (goto-char (1- e))) + (if was-comment + (progn + (setq REx-comment-end (point)) + (cperl-commentify + REx-comment-start REx-comment-end nil) + (cperl-postpone-fontification + REx-comment-start REx-comment-end + 'face font-lock-comment-face)))))) + (if (and is-REx is-x-REx) + (put-text-property (1+ b) (1- e) + 'syntax-subtype 'x-REx))) + (if i2 + (progn + (cperl-postpone-fontification + (1- e1) e1 'face font-lock-constant-face) + (if (assoc (char-after b) cperl-starters) + (cperl-postpone-fontification + b1 (1+ b1) 'face font-lock-constant-face)))) + (if (> (point) max) + (setq tmpend tb)))) + ((match-beginning 13) ; sub with prototypes + (setq b (match-beginning 0)) + (if (memq (char-after (1- b)) + '(?\$ ?\@ ?\% ?\& ?\*)) + nil + (setq state (parse-partial-sexp + state-point b nil nil state) + state-point b) + (if (or (nth 3 state) (nth 4 state)) + nil + ;; Mark as string + (cperl-commentify (match-beginning 13) (match-end 13) t)) + (goto-char (match-end 0)))) + ;; 1+6+2+1+1+2=13 extra () before this: + ;; "\\$\\(['{]\\)" + ((and (match-beginning 14) + (eq (preceding-char) ?\')) ; $' + (setq b (1- (point)) + state (parse-partial-sexp + state-point (1- b) nil nil state) + state-point (1- b)) + (if (nth 3 state) ; in string + (cperl-modify-syntax-type (1- b) cperl-st-punct)) + (goto-char (1+ b))) + ;; 1+6+2+1+1+2=13 extra () before this: + ;; "\\$\\(['{]\\)" + ((match-beginning 14) ; ${ + (setq bb (match-beginning 0)) + (cperl-modify-syntax-type bb cperl-st-punct)) + ;; 1+6+2+1+1+2+1=14 extra () before this: + ;; "\\(\\ non-quoting outside string/comment + (setq bb (match-end 0) + b (match-beginning 0)) + (goto-char b) + (skip-chars-backward "\\\\") + ;;;(setq i2 (= (% (skip-chars-backward "\\\\") 2) -1)) + (setq state (parse-partial-sexp + state-point b nil nil state) + state-point b) + (if (or (nth 3 state) (nth 4 state) ) + nil + (cperl-modify-syntax-type b cperl-st-punct)) + (goto-char bb)) + (t (error "Error in regexp of the sniffer"))) + (if (> (point) stop-point) + (progn + (if end + (message "Garbage after __END__/__DATA__ ignored") + (message "Unbalanced syntax found while scanning") + (or (car err-l) (setcar err-l b))) + (goto-char stop-point)))) + (setq cperl-syntax-state (cons state-point state) + cperl-syntax-done-to (or tmpend (max (point) max)))) + (if (car err-l) (goto-char (car err-l)) + (or non-inter + (message "Scanning for \"hard\" Perl constructions... done")))) + (and (buffer-modified-p) + (not modified) + (set-buffer-modified-p nil)) + (set-syntax-table cperl-mode-syntax-table)) + (car err-l))) + +(defun cperl-backward-to-noncomment (lim) + ;; Stops at lim or after non-whitespace that is not in comment + (let (stop p pr) + (while (and (not stop) (> (point) (or lim 1))) + (skip-chars-backward " \t\n\f" lim) + (setq p (point)) + (beginning-of-line) + (if (memq (setq pr (get-text-property (point) 'syntax-type)) + '(pod here-doc here-doc-delim)) + (cperl-unwind-to-safe nil) + (or (looking-at "^[ \t]*\\(#\\|$\\)") + (progn (cperl-to-comment-or-eol) (bolp)) + (progn + (skip-chars-backward " \t") + (if (< p (point)) (goto-char p)) + (setq stop t))))))) + +(defun cperl-after-block-p (lim &optional pre-block) + "Return true if the preceeding } ends a block or a following { starts one. +Would not look before LIM. If PRE-BLOCK is nil checks preceeding }. +otherwise following {." + ;; We suppose that the preceding char is }. + (save-excursion + (condition-case nil + (progn + (or pre-block (forward-sexp -1)) + (cperl-backward-to-noncomment lim) + (or (eq (point) lim) + (eq (preceding-char) ?\) ) ; if () {} sub f () {} + (if (eq (char-syntax (preceding-char)) ?w) ; else {} + (save-excursion + (forward-sexp -1) + (or (looking-at "\\(else\\|continue\\|grep\\|map\\|BEGIN\\|END\\|CHECK\\|INIT\\)\\>") + ;; sub f {} + (progn + (cperl-backward-to-noncomment lim) + (and (eq (char-syntax (preceding-char)) ?w) + (progn + (forward-sexp -1) + (looking-at "sub\\>")))))) + (cperl-after-expr-p lim)))) + (error nil)))) + +(defun cperl-after-expr-p (&optional lim chars test) + "Return true if the position is good for start of expression. +TEST is the expression to evaluate at the found position. If absent, +CHARS is a string that contains good characters to have before us (however, +`}' is treated \"smartly\" if it is not in the list)." + (let ((lim (or lim (point-min))) + stop p pr) + (cperl-update-syntaxification (point) (point)) + (save-excursion + (while (and (not stop) (> (point) lim)) + (skip-chars-backward " \t\n\f" lim) + (setq p (point)) + (beginning-of-line) + ;;(memq (setq pr (get-text-property (point) 'syntax-type)) + ;; '(pod here-doc here-doc-delim)) + (if (get-text-property (point) 'here-doc-group) + (progn + (goto-char + (previous-single-property-change (point) 'here-doc-group)) + (beginning-of-line 0))) + (if (get-text-property (point) 'in-pod) + (progn + (goto-char + (previous-single-property-change (point) 'in-pod)) + (beginning-of-line 0))) + (if (looking-at "^[ \t]*\\(#\\|$\\)") nil ; Only comment, skip + ;; Else: last iteration, or a label + (cperl-to-comment-or-eol) ; Will not move past "." after a format + (skip-chars-backward " \t") + (if (< p (point)) (goto-char p)) + (setq p (point)) + (if (and (eq (preceding-char) ?:) + (progn + (forward-char -1) + (skip-chars-backward " \t\n\f" lim) + (eq (char-syntax (preceding-char)) ?w))) + (forward-sexp -1) ; Possibly label. Skip it + (goto-char p) + (setq stop t)))) + (or (bobp) ; ???? Needed + (eq (point) lim) + (looking-at "[ \t]*__\\(END\\|DATA\\)__") ; After this anything goes + (progn + (if test (eval test) + (or (memq (preceding-char) (append (or chars "{;") nil)) + (and (eq (preceding-char) ?\}) + (cperl-after-block-p lim)) + (and (eq (following-char) ?.) ; in format: see comment above + (eq (get-text-property (point) 'syntax-type) + 'format))))))))) + +(defun cperl-backward-to-start-of-continued-exp (lim) + (if (memq (preceding-char) (append ")]}\"'`" nil)) + (forward-sexp -1)) + (beginning-of-line) + (if (<= (point) lim) + (goto-char (1+ lim))) + (skip-chars-forward " \t")) + +(defun cperl-after-block-and-statement-beg (lim) + ;; We assume that we are after ?\} + (and + (cperl-after-block-p lim) + (save-excursion + (forward-sexp -1) + (cperl-backward-to-noncomment (point-min)) + (or (bobp) + (eq (point) lim) + (not (= (char-syntax (preceding-char)) ?w)) + (progn + (forward-sexp -1) + (not + (looking-at + "\\(map\\|grep\\|printf?\\|system\\|exec\\|tr\\|s\\)\\>"))))))) + + +(defvar innerloop-done nil) +(defvar last-depth nil) + +(defun cperl-indent-exp () + "Simple variant of indentation of continued-sexp. + +Will not indent comment if it starts at `comment-indent' or looks like +continuation of the comment on the previous line. + +If `cperl-indent-region-fix-constructs', will improve spacing on +conditional/loop constructs." + (interactive) + (save-excursion + (let ((tmp-end (progn (end-of-line) (point))) top done) + (save-excursion + (beginning-of-line) + (while (null done) + (setq top (point)) + (while (= (nth 0 (parse-partial-sexp (point) tmp-end + -1)) -1) + (setq top (point))) ; Get the outermost parenths in line + (goto-char top) + (while (< (point) tmp-end) + (parse-partial-sexp (point) tmp-end nil t) ; To start-sexp or eol + (or (eolp) (forward-sexp 1))) + (if (> (point) tmp-end) + (save-excursion + (end-of-line) + (setq tmp-end (point))) + (setq done t))) + (goto-char tmp-end) + (setq tmp-end (point-marker))) + (if cperl-indent-region-fix-constructs + (cperl-fix-line-spacing tmp-end)) + (cperl-indent-region (point) tmp-end)))) + +(defun cperl-fix-line-spacing (&optional end parse-data) + "Improve whitespace in a conditional/loop construct. +Returns some position at the last line." + (interactive) + (or end + (setq end (point-max))) + (let ((ee (save-excursion (end-of-line) (point))) + (cperl-indent-region-fix-constructs + (or cperl-indent-region-fix-constructs 1)) + p pp ml have-brace ret) + (save-excursion + (beginning-of-line) + (setq ret (point)) + ;; }? continue + ;; blah; } + (if (not + (or (looking-at "[ \t]*\\(els\\(e\\|if\\)\\|continue\\|if\\|while\\|for\\(each\\)?\\|until\\)") + (setq have-brace (save-excursion (search-forward "}" ee t))))) + nil ; Do not need to do anything + ;; Looking at: + ;; } + ;; else + (if (and cperl-merge-trailing-else + (looking-at + "[ \t]*}[ \t]*\n[ \t\n]*\\(els\\(e\\|if\\)\\|continue\\)\\>")) + (progn + (search-forward "}") + (setq p (point)) + (skip-chars-forward " \t\n") + (delete-region p (point)) + (insert (make-string cperl-indent-region-fix-constructs ?\ )) + (beginning-of-line))) + ;; Looking at: + ;; } else + (if (looking-at "[ \t]*}\\(\t*\\|[ \t][ \t]+\\)\\<\\(els\\(e\\|if\\)\\|continue\\)\\>") + (progn + (search-forward "}") + (delete-horizontal-space) + (insert (make-string cperl-indent-region-fix-constructs ?\ )) + (beginning-of-line))) + ;; Looking at: + ;; else { + (if (looking-at + "[ \t]*}?[ \t]*\\<\\(\\els\\(e\\|if\\)\\|continue\\|unless\\|if\\|while\\|for\\(each\\)?\\|until\\)\\>\\(\t*\\|[ \t][ \t]+\\)[^ \t\n#]") + (progn + (forward-word 1) + (delete-horizontal-space) + (insert (make-string cperl-indent-region-fix-constructs ?\ )) + (beginning-of-line))) + ;; Looking at: + ;; foreach my $var + (if (looking-at + "[ \t]*\\\\([ \t]*(\\|[ \t\n]*{\\)\\|[ \t]*{") + (progn + (setq ml (match-beginning 8)) + (re-search-forward "[({]") + (forward-char -1) + (setq p (point)) + (if (eq (following-char) ?\( ) + (progn + (forward-sexp 1) + (setq pp (point))) + ;; after `else' or nothing + (if ml ; after `else' + (skip-chars-backward " \t\n") + (beginning-of-line)) + (setq pp nil)) + ;; Now after the sexp before the brace + ;; Multiline expr should be special + (setq ml (and pp (save-excursion (goto-char p) + (search-forward "\n" pp t)))) + (if (and (or (not pp) (< pp end)) + (looking-at "[ \t\n]*{")) + (progn + (cond + ((bolp) ; Were before `{', no if/else/etc + nil) + ((looking-at "\\(\t*\\| [ \t]+\\){") + (delete-horizontal-space) + (if (if ml + cperl-extra-newline-before-brace-multiline + cperl-extra-newline-before-brace) + (progn + (delete-horizontal-space) + (insert "\n") + (setq ret (point)) + (if (cperl-indent-line parse-data) + (progn + (cperl-fix-line-spacing end parse-data) + (setq ret (point))))) + (insert + (make-string cperl-indent-region-fix-constructs ?\ )))) + ((and (looking-at "[ \t]*\n") + (not (if ml + cperl-extra-newline-before-brace-multiline + cperl-extra-newline-before-brace))) + (setq pp (point)) + (skip-chars-forward " \t\n") + (delete-region pp (point)) + (insert + (make-string cperl-indent-region-fix-constructs ?\ )))) + ;; Now we are before `{' + (if (looking-at "[ \t\n]*{[ \t]*[^ \t\n#]") + (progn + (skip-chars-forward " \t\n") + (setq pp (point)) + (forward-sexp 1) + (setq p (point)) + (goto-char pp) + (setq ml (search-forward "\n" p t)) + (if (or cperl-break-one-line-blocks-when-indent ml) + ;; not good: multi-line BLOCK + (progn + (goto-char (1+ pp)) + (delete-horizontal-space) + (insert "\n") + (setq ret (point)) + (if (cperl-indent-line parse-data) + (setq ret (cperl-fix-line-spacing end parse-data))))))))))) + (beginning-of-line) + (setq p (point) pp (save-excursion (end-of-line) (point))) ; May be different from ee. + ;; Now check whether there is a hanging `}' + ;; Looking at: + ;; } blah + (if (and + cperl-fix-hanging-brace-when-indent + have-brace + (not (looking-at "[ \t]*}[ \t]*\\(\\<\\(els\\(if\\|e\\)\\|continue\\|while\\|until\\)\\>\\|$\\|#\\)")) + (condition-case nil + (progn + (up-list 1) + (if (and (<= (point) pp) + (eq (preceding-char) ?\} ) + (cperl-after-block-and-statement-beg (point-min))) + t + (goto-char p) + nil)) + (error nil))) + (progn + (forward-char -1) + (skip-chars-backward " \t") + (if (bolp) + ;; `}' was the first thing on the line, insert NL *after* it. + (progn + (cperl-indent-line parse-data) + (search-forward "}") + (delete-horizontal-space) + (insert "\n")) + (delete-horizontal-space) + (or (eq (preceding-char) ?\;) + (bolp) + (and (eq (preceding-char) ?\} ) + (cperl-after-block-p (point-min))) + (insert ";")) + (insert "\n") + (setq ret (point))) + (if (cperl-indent-line parse-data) + (setq ret (cperl-fix-line-spacing end parse-data))) + (beginning-of-line))))) + ret)) + +(defvar cperl-update-start) ; Do not need to make them local +(defvar cperl-update-end) +(defun cperl-delay-update-hook (beg end old-len) + (setq cperl-update-start (min beg (or cperl-update-start (point-max)))) + (setq cperl-update-end (max end (or cperl-update-end (point-min))))) + +(defun cperl-indent-region (start end) + "Simple variant of indentation of region in CPerl mode. +Should be slow. Will not indent comment if it starts at `comment-indent' +or looks like continuation of the comment on the previous line. +Indents all the lines whose first character is between START and END +inclusive. + +If `cperl-indent-region-fix-constructs', will improve spacing on +conditional/loop constructs." + (interactive "r") + (cperl-update-syntaxification end end) + (save-excursion + (let (cperl-update-start cperl-update-end (h-a-c after-change-functions)) + (let ((indent-info (if cperl-emacs-can-parse + (list nil nil nil) ; Cannot use '(), since will modify + nil)) + (pm 0) (imenu-scanning-message "Indenting... (%3d%%)") + after-change-functions ; Speed it up! + st comm old-comm-indent new-comm-indent p pp i empty) + (if h-a-c (add-hook 'after-change-functions 'cperl-delay-update-hook)) + (goto-char start) + (setq old-comm-indent (and (cperl-to-comment-or-eol) + (current-column)) + new-comm-indent old-comm-indent) + (goto-char start) + (setq end (set-marker (make-marker) end)) ; indentation changes pos + (or (bolp) (beginning-of-line 2)) + (or (fboundp 'imenu-progress-message) + (message "Indenting... For feedback load `imenu'...")) + (while (and (<= (point) end) (not (eobp))) ; bol to check start + (and (fboundp 'imenu-progress-message) + (imenu-progress-message + pm (/ (* 100 (- (point) start)) (- end start -1)))) + (setq st (point)) + (if (or + (setq empty (looking-at "[ \t]*\n")) + (and (setq comm (looking-at "[ \t]*#")) + (or (eq (current-indentation) (or old-comm-indent + comment-column)) + (setq old-comm-indent nil)))) + (if (and old-comm-indent + (not empty) + (= (current-indentation) old-comm-indent) + (not (eq (get-text-property (point) 'syntax-type) 'pod)) + (not (eq (get-text-property (point) 'syntax-table) + cperl-st-cfence))) + (let ((comment-column new-comm-indent)) + (indent-for-comment))) + (progn + (setq i (cperl-indent-line indent-info)) + (or comm + (not i) + (progn + (if cperl-indent-region-fix-constructs + (goto-char (cperl-fix-line-spacing end indent-info))) + (if (setq old-comm-indent + (and (cperl-to-comment-or-eol) + (not (memq (get-text-property (point) + 'syntax-type) + '(pod here-doc))) + (not (eq (get-text-property (point) + 'syntax-table) + cperl-st-cfence)) + (current-column))) + (progn (indent-for-comment) + (skip-chars-backward " \t") + (skip-chars-backward "#") + (setq new-comm-indent (current-column)))))))) + (beginning-of-line 2)) + (if (fboundp 'imenu-progress-message) + (imenu-progress-message pm 100) + (message nil))) + ;; Now run the update hooks + (and after-change-functions + cperl-update-end + (save-excursion + (goto-char cperl-update-end) + (insert " ") + (delete-char -1) + (goto-char cperl-update-start) + (insert " ") + (delete-char -1)))))) + +;; Stolen from lisp-mode with a lot of improvements + +(defun cperl-fill-paragraph (&optional justify iteration) + "Like \\[fill-paragraph], but handle CPerl comments. +If any of the current line is a comment, fill the comment or the +block of it that point is in, preserving the comment's initial +indentation and initial hashes. Behaves usually outside of comment." + (interactive "P") + (let (;; Non-nil if the current line contains a comment. + has-comment + + ;; If has-comment, the appropriate fill-prefix for the comment. + comment-fill-prefix + ;; Line that contains code and comment (or nil) + start + c spaces len dc (comment-column comment-column)) + ;; Figure out what kind of comment we are looking at. + (save-excursion + (beginning-of-line) + (cond + + ;; A line with nothing but a comment on it? + ((looking-at "[ \t]*#[# \t]*") + (setq has-comment t + comment-fill-prefix (buffer-substring (match-beginning 0) + (match-end 0)))) + + ;; A line with some code, followed by a comment? Remember that the + ;; semi which starts the comment shouldn't be part of a string or + ;; character. + ((cperl-to-comment-or-eol) + (setq has-comment t) + (looking-at "#+[ \t]*") + (setq start (point) c (current-column) + comment-fill-prefix + (concat (make-string (current-column) ?\ ) + (buffer-substring (match-beginning 0) (match-end 0))) + spaces (progn (skip-chars-backward " \t") + (buffer-substring (point) start)) + dc (- c (current-column)) len (- start (point)) + start (point-marker)) + (delete-char len) + (insert (make-string dc ?-))))) + (if (not has-comment) + (fill-paragraph justify) ; Do the usual thing outside of comment + ;; Narrow to include only the comment, and then fill the region. + (save-restriction + (narrow-to-region + ;; Find the first line we should include in the region to fill. + (if start (progn (beginning-of-line) (point)) + (save-excursion + (while (and (zerop (forward-line -1)) + (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]"))) + ;; We may have gone to far. Go forward again. + (or (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]") + (forward-line 1)) + (point))) + ;; Find the beginning of the first line past the region to fill. + (save-excursion + (while (progn (forward-line 1) + (looking-at "^[ \t]*#+[ \t]*[^ \t\n#]"))) + (point))) + ;; Remove existing hashes + (goto-char (point-min)) + (while (progn (forward-line 1) (< (point) (point-max))) + (skip-chars-forward " \t") + (and (looking-at "#+") + (delete-char (- (match-end 0) (match-beginning 0))))) + + ;; Lines with only hashes on them can be paragraph boundaries. + (let ((paragraph-start (concat paragraph-start "\\|^[ \t#]*$")) + (paragraph-separate (concat paragraph-start "\\|^[ \t#]*$")) + (fill-prefix comment-fill-prefix)) + (fill-paragraph justify))) + (if (and start) + (progn + (goto-char start) + (if (> dc 0) + (progn (delete-char dc) (insert spaces))) + (if (or (= (current-column) c) iteration) nil + (setq comment-column c) + (indent-for-comment) + ;; Repeat once more, flagging as iteration + (cperl-fill-paragraph justify t))))))) + +(defun cperl-do-auto-fill () + ;; Break out if the line is short enough + (if (> (save-excursion + (end-of-line) + (current-column)) + fill-column) + (let ((c (save-excursion (beginning-of-line) + (cperl-to-comment-or-eol) (point))) + (s (memq (following-char) '(?\ ?\t))) marker) + (if (>= c (point)) nil + (setq marker (point-marker)) + (cperl-fill-paragraph) + (goto-char marker) + ;; Is not enough, sometimes marker is a start of line + (if (bolp) (progn (re-search-forward "#+[ \t]*") + (goto-char (match-end 0)))) + ;; Following space could have gone: + (if (or (not s) (memq (following-char) '(?\ ?\t))) nil + (insert " ") + (backward-char 1)) + ;; Previous space could have gone: + (or (memq (preceding-char) '(?\ ?\t)) (insert " ")))))) + +(defun cperl-imenu-addback (lst &optional isback name) + ;; We suppose that the lst is a DAG, unless the first element only + ;; loops back, and ISBACK is set. Thus this function cannot be + ;; applied twice without ISBACK set. + (cond ((not cperl-imenu-addback) lst) + (t + (or name + (setq name "+++BACK+++")) + (mapcar (lambda (elt) + (if (and (listp elt) (listp (cdr elt))) + (progn + ;; In the other order it goes up + ;; one level only ;-( + (setcdr elt (cons (cons name lst) + (cdr elt))) + (cperl-imenu-addback (cdr elt) t name)))) + (if isback (cdr lst) lst)) + lst))) + +(defun cperl-imenu--create-perl-index (&optional regexp) + (require 'cl) + (require 'imenu) ; May be called from TAGS creator + (let ((index-alist '()) (index-pack-alist '()) (index-pod-alist '()) + (index-unsorted-alist '()) (i-s-f (default-value 'imenu-sort-function)) + (index-meth-alist '()) meth + packages ends-ranges p marker + (prev-pos 0) char fchar index index1 name (end-range 0) package) + (goto-char (point-min)) + (if noninteractive + (message "Scanning Perl for index") + (imenu-progress-message prev-pos 0)) + (cperl-update-syntaxification (point-max) (point-max)) + ;; Search for the function + (progn ;;save-match-data + (while (re-search-forward + (or regexp cperl-imenu--function-name-regexp-perl) + nil t) + (or noninteractive + (imenu-progress-message prev-pos)) + (cond + ((and ; Skip some noise if building tags + (match-beginning 2) ; package or sub + (eq (char-after (match-beginning 2)) ?p) ; package + (not (save-match-data + (looking-at "[ \t\n]*;")))) ; Plain text word 'package' + nil) + ((and + (match-beginning 2) ; package or sub + ;; Skip if quoted (will not skip multi-line ''-strings :-(): + (null (get-text-property (match-beginning 1) 'syntax-table)) + (null (get-text-property (match-beginning 1) 'syntax-type)) + (null (get-text-property (match-beginning 1) 'in-pod))) + (save-excursion + (goto-char (match-beginning 2)) + (setq fchar (following-char))) + ;; (if (looking-at "([^()]*)[ \t\n\f]*") + ;; (goto-char (match-end 0))) ; Messes what follows + (setq char (following-char) ; ?\; for "sub foo () ;" + meth nil + p (point)) + (while (and ends-ranges (>= p (car ends-ranges))) + ;; delete obsolete entries + (setq ends-ranges (cdr ends-ranges) packages (cdr packages))) + (setq package (or (car packages) "") + end-range (or (car ends-ranges) 0)) + (if (eq fchar ?p) + (setq name (buffer-substring (match-beginning 3) (match-end 3)) + name (progn + (set-text-properties 0 (length name) nil name) + name) + package (concat name "::") + name (concat "package " name) + end-range + (save-excursion + (parse-partial-sexp (point) (point-max) -1) (point)) + ends-ranges (cons end-range ends-ranges) + packages (cons package packages))) + ;; ) + ;; Skip this function name if it is a prototype declaration. + (if (and (eq fchar ?s) (eq char ?\;)) nil + (setq name (buffer-substring (match-beginning 3) (match-end 3)) + marker (make-marker)) + (set-text-properties 0 (length name) nil name) + (set-marker marker (match-end 3)) + (if (eq fchar ?p) + (setq name (concat "package " name)) + (cond ((string-match "[:']" name) + (setq meth t)) + ((> p end-range) nil) + (t + (setq name (concat package name) meth t)))) + (setq index (cons name marker)) + (if (eq fchar ?p) + (push index index-pack-alist) + (push index index-alist)) + (if meth (push index index-meth-alist)) + (push index index-unsorted-alist))) + ((match-beginning 5) ; POD section + ;; (beginning-of-line) + (setq index (imenu-example--name-and-position) + name (buffer-substring (match-beginning 6) (match-end 6))) + (set-text-properties 0 (length name) nil name) + (if (eq (char-after (match-beginning 5)) ?2) + (setq name (concat " " name))) + (setcar index name) + (setq index1 (cons (concat "=" name) (cdr index))) + (push index index-pod-alist) + (push index1 index-unsorted-alist))))) + (or noninteractive + (imenu-progress-message prev-pos 100)) + (setq index-alist + (if (default-value 'imenu-sort-function) + (sort index-alist (default-value 'imenu-sort-function)) + (nreverse index-alist))) + (and index-pod-alist + (push (cons "+POD headers+..." + (nreverse index-pod-alist)) + index-alist)) + (and (or index-pack-alist index-meth-alist) + (let ((lst index-pack-alist) hier-list pack elt group name) + ;; Remove "package ", reverse and uniquify. + (while lst + (setq elt (car lst) lst (cdr lst) name (substring (car elt) 8)) + (if (assoc name hier-list) nil + (setq hier-list (cons (cons name (cdr elt)) hier-list)))) + (setq lst index-meth-alist) + (while lst + (setq elt (car lst) lst (cdr lst)) + (cond ((string-match "\\(::\\|'\\)[_a-zA-Z0-9]+$" (car elt)) + (setq pack (substring (car elt) 0 (match-beginning 0))) + (if (setq group (assoc pack hier-list)) + (if (listp (cdr group)) + ;; Have some functions already + (setcdr group + (cons (cons (substring + (car elt) + (+ 2 (match-beginning 0))) + (cdr elt)) + (cdr group))) + (setcdr group (list (cons (substring + (car elt) + (+ 2 (match-beginning 0))) + (cdr elt))))) + (setq hier-list + (cons (cons pack + (list (cons (substring + (car elt) + (+ 2 (match-beginning 0))) + (cdr elt)))) + hier-list)))))) + (push (cons "+Hierarchy+..." + hier-list) + index-alist))) + (and index-pack-alist + (push (cons "+Packages+..." + (nreverse index-pack-alist)) + index-alist)) + (and (or index-pack-alist index-pod-alist + (default-value 'imenu-sort-function)) + index-unsorted-alist + (push (cons "+Unsorted List+..." + (nreverse index-unsorted-alist)) + index-alist)) + (cperl-imenu-addback index-alist))) + + +;; Suggested by Mark A. Hershberger +(defun cperl-outline-level () + (looking-at outline-regexp) + (cond ((not (match-beginning 1)) 0) ; beginning-of-file + ((match-beginning 2) + (if (eq (char-after (match-beginning 2)) ?p) + 0 ; package + 1)) ; sub + ((match-beginning 5) + (if (eq (char-after (match-beginning 5)) ?1) + 1 ; head1 + 2)) ; head2 + (t 3))) ; should not happen + + +(defvar cperl-compilation-error-regexp-alist + ;; This look like a paranoiac regexp: could anybody find a better one? (which WORK). + '(("^[^\n]* \\(file\\|at\\) \\([^ \t\n]+\\) [^\n]*line \\([0-9]+\\)[\\., \n]" + 2 3)) + "Alist that specifies how to match errors in perl output.") + +(if (fboundp 'eval-after-load) + (eval-after-load + "mode-compile" + '(setq perl-compilation-error-regexp-alist + cperl-compilation-error-regexp-alist))) + + +(defun cperl-windowed-init () + "Initialization under windowed version." + (if (or (featurep 'ps-print) cperl-faces-init) + ;; Need to init anyway: + (or cperl-faces-init (cperl-init-faces)) + (add-hook 'font-lock-mode-hook + (function + (lambda () + (if (memq major-mode '(perl-mode cperl-mode)) + (progn + (or cperl-faces-init (cperl-init-faces))))))) + (if (fboundp 'eval-after-load) + (eval-after-load + "ps-print" + '(or cperl-faces-init (cperl-init-faces)))))) + +(defun cperl-load-font-lock-keywords () + (or cperl-faces-init (cperl-init-faces)) + perl-font-lock-keywords) + +(defun cperl-load-font-lock-keywords-1 () + (or cperl-faces-init (cperl-init-faces)) + perl-font-lock-keywords-1) + +(defun cperl-load-font-lock-keywords-2 () + (or cperl-faces-init (cperl-init-faces)) + perl-font-lock-keywords-2) + +(defvar perl-font-lock-keywords-1 nil + "Additional expressions to highlight in Perl mode. Minimal set.") +(defvar perl-font-lock-keywords nil + "Additional expressions to highlight in Perl mode. Default set.") +(defvar perl-font-lock-keywords-2 nil + "Additional expressions to highlight in Perl mode. Maximal set") + +(defvar font-lock-background-mode) +(defvar font-lock-display-type) +(defun cperl-init-faces-weak () + ;; Allow `cperl-find-pods-heres' to run. + (or (boundp 'font-lock-constant-face) + (cperl-force-face font-lock-constant-face + "Face for constant and label names") + ;;(setq font-lock-constant-face 'font-lock-constant-face) + )) + +(defun cperl-init-faces () + (condition-case errs + (progn + (require 'font-lock) + (and (fboundp 'font-lock-fontify-anchored-keywords) + (featurep 'font-lock-extra) + (message "You have an obsolete package `font-lock-extra'. Install `choose-color'.")) + (let (t-font-lock-keywords t-font-lock-keywords-1 font-lock-anchored) + (if (fboundp 'font-lock-fontify-anchored-keywords) + (setq font-lock-anchored t)) + (setq + t-font-lock-keywords + (list + (list "[ \t]+$" 0 cperl-invalid-face t) + (cons + (concat + "\\(^\\|[^$@%&\\]\\)\\<\\(" + (mapconcat + 'identity + '("if" "until" "while" "elsif" "else" "unless" "for" + "foreach" "continue" "exit" "die" "last" "goto" "next" + "redo" "return" "local" "exec" "sub" "do" "dump" "use" + "require" "package" "eval" "my" "BEGIN" "END" "CHECK" "INIT") + "\\|") ; Flow control + "\\)\\>") 2) ; was "\\)[ \n\t;():,\|&]" + ; In what follows we use `type' style + ; for overwritable builtins + (list + (concat + "\\(^\\|[^$@%&\\]\\)\\<\\(" + ;; "CORE" "__FILE__" "__LINE__" "abs" "accept" "alarm" + ;; "and" "atan2" "bind" "binmode" "bless" "caller" + ;; "chdir" "chmod" "chown" "chr" "chroot" "close" + ;; "closedir" "cmp" "connect" "continue" "cos" "crypt" + ;; "dbmclose" "dbmopen" "die" "dump" "endgrent" + ;; "endhostent" "endnetent" "endprotoent" "endpwent" + ;; "endservent" "eof" "eq" "exec" "exit" "exp" "fcntl" + ;; "fileno" "flock" "fork" "formline" "ge" "getc" + ;; "getgrent" "getgrgid" "getgrnam" "gethostbyaddr" + ;; "gethostbyname" "gethostent" "getlogin" + ;; "getnetbyaddr" "getnetbyname" "getnetent" + ;; "getpeername" "getpgrp" "getppid" "getpriority" + ;; "getprotobyname" "getprotobynumber" "getprotoent" + ;; "getpwent" "getpwnam" "getpwuid" "getservbyname" + ;; "getservbyport" "getservent" "getsockname" + ;; "getsockopt" "glob" "gmtime" "gt" "hex" "index" "int" + ;; "ioctl" "join" "kill" "lc" "lcfirst" "le" "length" + ;; "link" "listen" "localtime" "lock" "log" "lstat" "lt" + ;; "mkdir" "msgctl" "msgget" "msgrcv" "msgsnd" "ne" + ;; "not" "oct" "open" "opendir" "or" "ord" "pack" "pipe" + ;; "quotemeta" "rand" "read" "readdir" "readline" + ;; "readlink" "readpipe" "recv" "ref" "rename" "require" + ;; "reset" "reverse" "rewinddir" "rindex" "rmdir" "seek" + ;; "seekdir" "select" "semctl" "semget" "semop" "send" + ;; "setgrent" "sethostent" "setnetent" "setpgrp" + ;; "setpriority" "setprotoent" "setpwent" "setservent" + ;; "setsockopt" "shmctl" "shmget" "shmread" "shmwrite" + ;; "shutdown" "sin" "sleep" "socket" "socketpair" + ;; "sprintf" "sqrt" "srand" "stat" "substr" "symlink" + ;; "syscall" "sysopen" "sysread" "system" "syswrite" "tell" + ;; "telldir" "time" "times" "truncate" "uc" "ucfirst" + ;; "umask" "unlink" "unpack" "utime" "values" "vec" + ;; "wait" "waitpid" "wantarray" "warn" "write" "x" "xor" + "a\\(bs\\|ccept\\|tan2\\|larm\\|nd\\)\\|" + "b\\(in\\(d\\|mode\\)\\|less\\)\\|" + "c\\(h\\(r\\(\\|oot\\)\\|dir\\|mod\\|own\\)\\|aller\\|rypt\\|" + "lose\\(\\|dir\\)\\|mp\\|o\\(s\\|n\\(tinue\\|nect\\)\\)\\)\\|" + "CORE\\|d\\(ie\\|bm\\(close\\|open\\)\\|ump\\)\\|" + "e\\(x\\(p\\|it\\|ec\\)\\|q\\|nd\\(p\\(rotoent\\|went\\)\\|" + "hostent\\|servent\\|netent\\|grent\\)\\|of\\)\\|" + "f\\(ileno\\|cntl\\|lock\\|or\\(k\\|mline\\)\\)\\|" + "g\\(t\\|lob\\|mtime\\|e\\(\\|t\\(p\\(pid\\|r\\(iority\\|" + "oto\\(byn\\(ame\\|umber\\)\\|ent\\)\\)\\|eername\\|w" + "\\(uid\\|ent\\|nam\\)\\|grp\\)\\|host\\(by\\(addr\\|name\\)\\|" + "ent\\)\\|s\\(erv\\(by\\(port\\|name\\)\\|ent\\)\\|" + "ock\\(name\\|opt\\)\\)\\|c\\|login\\|net\\(by\\(addr\\|name\\)\\|" + "ent\\)\\|gr\\(ent\\|nam\\|gid\\)\\)\\)\\)\\|" + "hex\\|i\\(n\\(t\\|dex\\)\\|octl\\)\\|join\\|kill\\|" + "l\\(i\\(sten\\|nk\\)\\|stat\\|c\\(\\|first\\)\\|t\\|e" + "\\(\\|ngth\\)\\|o\\(c\\(altime\\|k\\)\\|g\\)\\)\\|m\\(sg\\(rcv\\|snd\\|" + "ctl\\|get\\)\\|kdir\\)\\|n\\(e\\|ot\\)\\|o\\(pen\\(\\|dir\\)\\|" + "r\\(\\|d\\)\\|ct\\)\\|p\\(ipe\\|ack\\)\\|quotemeta\\|" + "r\\(index\\|and\\|mdir\\|e\\(quire\\|ad\\(pipe\\|\\|lin" + "\\(k\\|e\\)\\|dir\\)\\|set\\|cv\\|verse\\|f\\|winddir\\|name" + "\\)\\)\\|s\\(printf\\|qrt\\|rand\\|tat\\|ubstr\\|e\\(t\\(p\\(r" + "\\(iority\\|otoent\\)\\|went\\|grp\\)\\|hostent\\|s\\(ervent\\|" + "ockopt\\)\\|netent\\|grent\\)\\|ek\\(\\|dir\\)\\|lect\\|" + "m\\(ctl\\|op\\|get\\)\\|nd\\)\\|h\\(utdown\\|m\\(read\\|ctl\\|" + "write\\|get\\)\\)\\|y\\(s\\(read\\|call\\|open\\|tem\\|write\\)\\|" + "mlink\\)\\|in\\|leep\\|ocket\\(pair\\|\\)\\)\\|t\\(runcate\\|" + "ell\\(\\|dir\\)\\|ime\\(\\|s\\)\\)\\|u\\(c\\(\\|first\\)\\|" + "time\\|mask\\|n\\(pack\\|link\\)\\)\\|v\\(alues\\|ec\\)\\|" + "w\\(a\\(rn\\|it\\(pid\\|\\)\\|ntarray\\)\\|rite\\)\\|" + "x\\(\\|or\\)\\|__\\(FILE__\\|LINE__\\|PACKAGE__\\)" + "\\)\\>") 2 'font-lock-type-face) + ;; In what follows we use `other' style + ;; for nonoverwritable builtins + ;; Somehow 's', 'm' are not auto-generated??? + (list + (concat + "\\(^\\|[^$@%&\\]\\)\\<\\(" + ;; "AUTOLOAD" "BEGIN" "CHECK" "DESTROY" "END" "INIT" "__END__" "chomp" + ;; "chop" "defined" "delete" "do" "each" "else" "elsif" + ;; "eval" "exists" "for" "foreach" "format" "goto" + ;; "grep" "if" "keys" "last" "local" "map" "my" "next" + ;; "no" "package" "pop" "pos" "print" "printf" "push" + ;; "q" "qq" "qw" "qx" "redo" "return" "scalar" "shift" + ;; "sort" "splice" "split" "study" "sub" "tie" "tr" + ;; "undef" "unless" "unshift" "untie" "until" "use" + ;; "while" "y" + "AUTOLOAD\\|BEGIN\\|CHECK\\|cho\\(p\\|mp\\)\\|d\\(e\\(fined\\|lete\\)\\|" + "o\\)\\|DESTROY\\|e\\(ach\\|val\\|xists\\|ls\\(e\\|if\\)\\)\\|" + "END\\|for\\(\\|each\\|mat\\)\\|g\\(rep\\|oto\\)\\|INIT\\|if\\|keys\\|" + "l\\(ast\\|ocal\\)\\|m\\(ap\\|y\\)\\|n\\(ext\\|o\\)\\|our\\|" + "p\\(ackage\\|rint\\(\\|f\\)\\|ush\\|o\\(p\\|s\\)\\)\\|" + "q\\(\\|q\\|w\\|x\\|r\\)\\|re\\(turn\\|do\\)\\|s\\(pli\\(ce\\|t\\)\\|" + "calar\\|tudy\\|ub\\|hift\\|ort\\)\\|t\\(r\\|ie\\)\\|" + "u\\(se\\|n\\(shift\\|ti\\(l\\|e\\)\\|def\\|less\\)\\)\\|" + "while\\|y\\|__\\(END\\|DATA\\)__" ;__DATA__ added manually + "\\|[sm]" ; Added manually + "\\)\\>") 2 'cperl-nonoverridable-face) + ;; (mapconcat 'identity + ;; '("#endif" "#else" "#ifdef" "#ifndef" "#if" + ;; "#include" "#define" "#undef") + ;; "\\|") + '("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0 + font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]" + '("\\*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" + (2 font-lock-string-face t) + (0 '(restart 2 t)))) ; To highlight $a{bc}{ef} + (font-lock-anchored + '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" + (2 font-lock-string-face t) + ("\\=[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" + nil nil + (1 font-lock-string-face t)))) + (t '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" + 2 font-lock-string-face t))) + '("[\[ \t{,(]\\(-?[a-zA-Z0-9_:]+\\)[ \t]*=>" 1 + font-lock-string-face t) + '("^[ \t]*\\([a-zA-Z0-9_]+[ \t]*:\\)[ \t]*\\($\\|{\\|\\<\\(until\\|while\\|for\\(each\\)?\\|do\\)\\>\\)" 1 + font-lock-constant-face) ; labels + '("\\<\\(continue\\|next\\|last\\|redo\\|goto\\)\\>[ \t]+\\([a-zA-Z0-9_:]+\\)" ; labels as targets + 2 font-lock-constant-face) + ;; Uncomment to get perl-mode-like vars + ;;; '("[$*]{?\\(\\sw+\\)" 1 font-lock-variable-name-face) + ;;; '("\\([@%]\\|\\$#\\)\\(\\sw+\\)" + ;;; (2 (cons font-lock-variable-name-face '(underline)))) + (cond ((featurep 'font-lock-extra) + '("^[ \t]*\\(my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?" + (3 font-lock-variable-name-face) + (4 '(another 4 nil + ("\\=[ \t]*,[ \t]*\\([$@%*][a-zA-Z0-9_:]+\\)\\([ \t]*,\\)?" + (1 font-lock-variable-name-face) + (2 '(restart 2 nil) nil t))) + nil t))) ; local variables, multiple + (font-lock-anchored + '("^[ \t{}]*\\(my\\|local\\|our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" + (3 font-lock-variable-name-face) + ("\\=[ \t]*,[ \t]*\\([$@%*][a-zA-Z0-9_:]+\\)" + nil nil + (1 font-lock-variable-name-face)))) + (t '("^[ \t{}]*\\(my\\|local\\our\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)" + 3 font-lock-variable-name-face))) + '("\\= 19.12 + ;; ((fboundp 'valid-color-name-p) 'valid-color-name-p) + ;; ;; XEmacs 19.11 + ;; (t 'x-valid-color-name-p)))) + (cperl-force-face font-lock-constant-face + "Face for constant and label names") + (cperl-force-face font-lock-variable-name-face + "Face for variable names") + (cperl-force-face font-lock-type-face + "Face for data types") + (cperl-force-face cperl-nonoverridable-face + "Face for data types from another group") + (cperl-force-face font-lock-comment-face + "Face for comments") + (cperl-force-face font-lock-function-name-face + "Face for function names") + (cperl-force-face cperl-hash-face + "Face for hashes") + (cperl-force-face cperl-array-face + "Face for arrays") + ;;(defvar font-lock-constant-face 'font-lock-constant-face) + ;;(defvar font-lock-variable-name-face 'font-lock-variable-name-face) + ;;(or (boundp 'font-lock-type-face) + ;; (defconst font-lock-type-face + ;; 'font-lock-type-face + ;; "Face to use for data types.")) + ;;(or (boundp 'cperl-nonoverridable-face) + ;; (defconst cperl-nonoverridable-face + ;; 'cperl-nonoverridable-face + ;; "Face to use for data types from another group.")) + ;;(if (not cperl-xemacs-p) nil + ;; (or (boundp 'font-lock-comment-face) + ;; (defconst font-lock-comment-face + ;; 'font-lock-comment-face + ;; "Face to use for comments.")) + ;; (or (boundp 'font-lock-keyword-face) + ;; (defconst font-lock-keyword-face + ;; 'font-lock-keyword-face + ;; "Face to use for keywords.")) + ;; (or (boundp 'font-lock-function-name-face) + ;; (defconst font-lock-function-name-face + ;; 'font-lock-function-name-face + ;; "Face to use for function names."))) + (if (and + (not (cperl-is-face 'cperl-array-face)) + (cperl-is-face 'font-lock-emphasized-face)) + (copy-face 'font-lock-emphasized-face 'cperl-array-face)) + (if (and + (not (cperl-is-face 'cperl-hash-face)) + (cperl-is-face 'font-lock-other-emphasized-face)) + (copy-face 'font-lock-other-emphasized-face + 'cperl-hash-face)) + (if (and + (not (cperl-is-face 'cperl-nonoverridable-face)) + (cperl-is-face 'font-lock-other-type-face)) + (copy-face 'font-lock-other-type-face + 'cperl-nonoverridable-face)) + ;;(or (boundp 'cperl-hash-face) + ;; (defconst cperl-hash-face + ;; 'cperl-hash-face + ;; "Face to use for hashes.")) + ;;(or (boundp 'cperl-array-face) + ;; (defconst cperl-array-face + ;; 'cperl-array-face + ;; "Face to use for arrays.")) + ;; Here we try to guess background + (let ((background + (if (boundp 'font-lock-background-mode) + font-lock-background-mode + 'light)) + (face-list (and (fboundp 'face-list) (face-list)))) +;;;; (fset 'cperl-is-face +;;;; (cond ((fboundp 'find-face) +;;;; (symbol-function 'find-face)) +;;;; (face-list +;;;; (function (lambda (face) (member face face-list)))) +;;;; (t +;;;; (function (lambda (face) (boundp face)))))) + (defvar cperl-guessed-background + (if (and (boundp 'font-lock-display-type) + (eq font-lock-display-type 'grayscale)) + 'gray + background) + "Background as guessed by CPerl mode") + (and (not (cperl-is-face 'font-lock-constant-face)) + (cperl-is-face 'font-lock-reference-face) + (copy-face 'font-lock-reference-face 'font-lock-constant-face)) + (if (cperl-is-face 'font-lock-type-face) nil + (copy-face 'default 'font-lock-type-face) + (cond + ((eq background 'light) + (set-face-foreground 'font-lock-type-face + (if (x-color-defined-p "seagreen") + "seagreen" + "sea green"))) + ((eq background 'dark) + (set-face-foreground 'font-lock-type-face + (if (x-color-defined-p "os2pink") + "os2pink" + "pink"))) + (t + (set-face-background 'font-lock-type-face "gray90")))) + (if (cperl-is-face 'cperl-nonoverridable-face) + nil + (copy-face 'font-lock-type-face 'cperl-nonoverridable-face) + (cond + ((eq background 'light) + (set-face-foreground 'cperl-nonoverridable-face + (if (x-color-defined-p "chartreuse3") + "chartreuse3" + "chartreuse"))) + ((eq background 'dark) + (set-face-foreground 'cperl-nonoverridable-face + (if (x-color-defined-p "orchid1") + "orchid1" + "orange"))))) +;;; (if (cperl-is-face 'font-lock-other-emphasized-face) nil +;;; (copy-face 'bold-italic 'font-lock-other-emphasized-face) +;;; (cond +;;; ((eq background 'light) +;;; (set-face-background 'font-lock-other-emphasized-face +;;; (if (x-color-defined-p "lightyellow2") +;;; "lightyellow2" +;;; (if (x-color-defined-p "lightyellow") +;;; "lightyellow" +;;; "light yellow")))) +;;; ((eq background 'dark) +;;; (set-face-background 'font-lock-other-emphasized-face +;;; (if (x-color-defined-p "navy") +;;; "navy" +;;; (if (x-color-defined-p "darkgreen") +;;; "darkgreen" +;;; "dark green")))) +;;; (t (set-face-background 'font-lock-other-emphasized-face "gray90")))) +;;; (if (cperl-is-face 'font-lock-emphasized-face) nil +;;; (copy-face 'bold 'font-lock-emphasized-face) +;;; (cond +;;; ((eq background 'light) +;;; (set-face-background 'font-lock-emphasized-face +;;; (if (x-color-defined-p "lightyellow2") +;;; "lightyellow2" +;;; "lightyellow"))) +;;; ((eq background 'dark) +;;; (set-face-background 'font-lock-emphasized-face +;;; (if (x-color-defined-p "navy") +;;; "navy" +;;; (if (x-color-defined-p "darkgreen") +;;; "darkgreen" +;;; "dark green")))) +;;; (t (set-face-background 'font-lock-emphasized-face "gray90")))) + (if (cperl-is-face 'font-lock-variable-name-face) nil + (copy-face 'italic 'font-lock-variable-name-face)) + (if (cperl-is-face 'font-lock-constant-face) nil + (copy-face 'italic 'font-lock-constant-face)))) + (setq cperl-faces-init t)) + (error (message "cperl-init-faces (ignored): %s" errs)))) + + +(defun cperl-ps-print-init () + "Initialization of `ps-print' components for faces used in CPerl." + (eval-after-load "ps-print" + '(setq ps-bold-faces + ;; font-lock-variable-name-face + ;; font-lock-constant-face + (append '(cperl-array-face + cperl-hash-face) + ps-bold-faces) + ps-italic-faces + ;; font-lock-constant-face + (append '(cperl-nonoverridable-face + cperl-hash-face) + ps-italic-faces) + ps-underlined-faces + ;; font-lock-type-face + (append '(cperl-array-face + cperl-hash-face + underline + cperl-nonoverridable-face) + ps-underlined-faces)))) + +(defvar ps-print-face-extension-alist) + +(defun cperl-ps-print (&optional file) + "Pretty-print in CPerl style. +If optional argument FILE is an empty string, prints to printer, otherwise +to the file FILE. If FILE is nil, prompts for a file name. + +Style of printout regulated by the variable `cperl-ps-print-face-properties'." + (interactive) + (or file + (setq file (read-from-minibuffer + "Print to file (if empty - to printer): " + (concat (buffer-file-name) ".ps") + nil nil 'file-name-history))) + (or (> (length file) 0) + (setq file nil)) + (require 'ps-print) ; To get ps-print-face-extension-alist + (let ((ps-print-color-p t) + (ps-print-face-extension-alist ps-print-face-extension-alist)) + (cperl-ps-extend-face-list cperl-ps-print-face-properties) + (ps-print-buffer-with-faces file))) + +;;; (defun cperl-ps-print-init () +;;; "Initialization of `ps-print' components for faces used in CPerl." +;;; ;; Guard against old versions +;;; (defvar ps-underlined-faces nil) +;;; (defvar ps-bold-faces nil) +;;; (defvar ps-italic-faces nil) +;;; (setq ps-bold-faces +;;; (append '(font-lock-emphasized-face +;;; cperl-array-face +;;; font-lock-keyword-face +;;; font-lock-variable-name-face +;;; font-lock-constant-face +;;; font-lock-reference-face +;;; font-lock-other-emphasized-face +;;; cperl-hash-face) +;;; ps-bold-faces)) +;;; (setq ps-italic-faces +;;; (append '(cperl-nonoverridable-face +;;; font-lock-constant-face +;;; font-lock-reference-face +;;; font-lock-other-emphasized-face +;;; cperl-hash-face) +;;; ps-italic-faces)) +;;; (setq ps-underlined-faces +;;; (append '(font-lock-emphasized-face +;;; cperl-array-face +;;; font-lock-other-emphasized-face +;;; cperl-hash-face +;;; cperl-nonoverridable-face font-lock-type-face) +;;; ps-underlined-faces)) +;;; (cons 'font-lock-type-face ps-underlined-faces)) + + +(if (cperl-enable-font-lock) (cperl-windowed-init)) + +(defconst cperl-styles-entries + '(cperl-indent-level cperl-brace-offset cperl-continued-brace-offset + cperl-label-offset cperl-extra-newline-before-brace + cperl-merge-trailing-else + cperl-continued-statement-offset)) + +(defconst cperl-style-alist + '(("CPerl" ; =GNU without extra-newline-before-brace + (cperl-indent-level . 2) + (cperl-brace-offset . 0) + (cperl-continued-brace-offset . 0) + (cperl-label-offset . -2) + (cperl-extra-newline-before-brace . nil) + (cperl-merge-trailing-else . t) + (cperl-continued-statement-offset . 2)) + ("PerlStyle" ; CPerl with 4 as indent + (cperl-indent-level . 4) + (cperl-brace-offset . 0) + (cperl-continued-brace-offset . 0) + (cperl-label-offset . -4) + (cperl-extra-newline-before-brace . nil) + (cperl-merge-trailing-else . t) + (cperl-continued-statement-offset . 4)) + ("GNU" + (cperl-indent-level . 2) + (cperl-brace-offset . 0) + (cperl-continued-brace-offset . 0) + (cperl-label-offset . -2) + (cperl-extra-newline-before-brace . t) + (cperl-merge-trailing-else . nil) + (cperl-continued-statement-offset . 2)) + ("K&R" + (cperl-indent-level . 5) + (cperl-brace-offset . 0) + (cperl-continued-brace-offset . -5) + (cperl-label-offset . -5) + ;;(cperl-extra-newline-before-brace . nil) ; ??? + (cperl-merge-trailing-else . nil) + (cperl-continued-statement-offset . 5)) + ("BSD" + (cperl-indent-level . 4) + (cperl-brace-offset . 0) + (cperl-continued-brace-offset . -4) + (cperl-label-offset . -4) + ;;(cperl-extra-newline-before-brace . nil) ; ??? + (cperl-continued-statement-offset . 4)) + ("C++" + (cperl-indent-level . 4) + (cperl-brace-offset . 0) + (cperl-continued-brace-offset . -4) + (cperl-label-offset . -4) + (cperl-continued-statement-offset . 4) + (cperl-merge-trailing-else . nil) + (cperl-extra-newline-before-brace . t)) + ("Current") + ("Whitesmith" + (cperl-indent-level . 4) + (cperl-brace-offset . 0) + (cperl-continued-brace-offset . 0) + (cperl-label-offset . -4) + ;;(cperl-extra-newline-before-brace . nil) ; ??? + (cperl-continued-statement-offset . 4))) + "(Experimental) list of variables to set to get a particular indentation style. +Should be used via `cperl-set-style' or via Perl menu.") + +(defun cperl-set-style (style) + "Set CPerl mode variables to use one of several different indentation styles. +The arguments are a string representing the desired style. +The list of styles is in `cperl-style-alist', available styles +are GNU, K&R, BSD, C++ and Whitesmith. + +The current value of style is memorized (unless there is a memorized +data already), may be restored by `cperl-set-style-back'. + +Chosing \"Current\" style will not change style, so this may be used for +side-effect of memorizing only." + (interactive + (let ((list (mapcar (function (lambda (elt) (list (car elt)))) + cperl-style-alist))) + (list (completing-read "Enter style: " list nil 'insist)))) + (or cperl-old-style + (setq cperl-old-style + (mapcar (function + (lambda (name) + (cons name (eval name)))) + cperl-styles-entries))) + (let ((style (cdr (assoc style cperl-style-alist))) setting str sym) + (while style + (setq setting (car style) style (cdr style)) + (set (car setting) (cdr setting))))) + +(defun cperl-set-style-back () + "Restore a style memorised by `cperl-set-style'." + (interactive) + (or cperl-old-style (error "The style was not changed")) + (let (setting) + (while cperl-old-style + (setq setting (car cperl-old-style) + cperl-old-style (cdr cperl-old-style)) + (set (car setting) (cdr setting))))) + +(defun cperl-check-syntax () + (interactive) + (require 'mode-compile) + (let ((perl-dbg-flags (concat cperl-extra-perl-args " -wc"))) + (eval '(mode-compile)))) ; Avoid a warning + +(defun cperl-info-buffer (type) + ;; Returns buffer with documentation. Creates if missing. + ;; If TYPE, this vars buffer. + ;; Special care is taken to not stomp over an existing info buffer + (let* ((bname (if type "*info-perl-var*" "*info-perl*")) + (info (get-buffer bname)) + (oldbuf (get-buffer "*info*"))) + (if info info + (save-window-excursion + ;; Get Info running + (require 'info) + (cond (oldbuf + (set-buffer oldbuf) + (rename-buffer "*info-perl-tmp*"))) + (save-window-excursion + (info)) + (Info-find-node cperl-info-page (if type "perlvar" "perlfunc")) + (set-buffer "*info*") + (rename-buffer bname) + (cond (oldbuf + (set-buffer "*info-perl-tmp*") + (rename-buffer "*info*") + (set-buffer bname))) + (make-local-variable 'window-min-height) + (setq window-min-height 2) + (current-buffer))))) + +(defun cperl-word-at-point (&optional p) + "Return the word at point or at P." + (save-excursion + (if p (goto-char p)) + (or (cperl-word-at-point-hard) + (progn + (require 'etags) + (funcall (or (and (boundp 'find-tag-default-function) + find-tag-default-function) + (get major-mode 'find-tag-default-function) + ;; XEmacs 19.12 has `find-tag-default-hook'; it is + ;; automatically used within `find-tag-default': + 'find-tag-default)))))) + +(defun cperl-info-on-command (command) + "Show documentation for Perl command COMMAND in other window. +If perl-info buffer is shown in some frame, uses this frame. +Customized by setting variables `cperl-shrink-wrap-info-frame', +`cperl-max-help-size'." + (interactive + (let* ((default (cperl-word-at-point)) + (read (read-string + (format "Find doc for Perl function (default %s): " + default)))) + (list (if (equal read "") + default + read)))) + + (let ((buffer (current-buffer)) + (cmd-desc (concat "^" (regexp-quote command) "[^a-zA-Z_0-9]")) ; "tr///" + pos isvar height iniheight frheight buf win fr1 fr2 iniwin not-loner + max-height char-height buf-list) + (if (string-match "^-[a-zA-Z]$" command) + (setq cmd-desc "^-X[ \t\n]")) + (setq isvar (string-match "^[$@%]" command) + buf (cperl-info-buffer isvar) + iniwin (selected-window) + fr1 (window-frame iniwin)) + (set-buffer buf) + (beginning-of-buffer) + (or isvar + (progn (re-search-forward "^-X[ \t\n]") + (forward-line -1))) + (if (re-search-forward cmd-desc nil t) + (progn + ;; Go back to beginning of the group (ex, for qq) + (if (re-search-backward "^[ \t\n\f]") + (forward-line 1)) + (beginning-of-line) + ;; Get some of + (setq pos (point) + buf-list (list buf "*info-perl-var*" "*info-perl*")) + (while (and (not win) buf-list) + (setq win (get-buffer-window (car buf-list) t)) + (setq buf-list (cdr buf-list))) + (or (not win) + (eq (window-buffer win) buf) + (set-window-buffer win buf)) + (and win (setq fr2 (window-frame win))) + (if (or (not fr2) (eq fr1 fr2)) + (pop-to-buffer buf) + (special-display-popup-frame buf) ; Make it visible + (select-window win)) + (goto-char pos) ; Needed (?!). + ;; Resize + (setq iniheight (window-height) + frheight (frame-height) + not-loner (< iniheight (1- frheight))) ; Are not alone + (cond ((if not-loner cperl-max-help-size + cperl-shrink-wrap-info-frame) + (setq height + (+ 2 + (count-lines + pos + (save-excursion + (if (re-search-forward + "^[ \t][^\n]*\n+\\([^ \t\n\f]\\|\\'\\)" nil t) + (match-beginning 0) (point-max))))) + max-height + (if not-loner + (/ (* (- frheight 3) cperl-max-help-size) 100) + (setq char-height (frame-char-height)) + ;; Non-functioning under OS/2: + (if (eq char-height 1) (setq char-height 18)) + ;; Title, menubar, + 2 for slack + (- (/ (x-display-pixel-height) char-height) 4))) + (if (> height max-height) (setq height max-height)) + ;;(message "was %s doing %s" iniheight height) + (if not-loner + (enlarge-window (- height iniheight)) + (set-frame-height (window-frame win) (1+ height))))) + (set-window-start (selected-window) pos)) + (message "No entry for %s found." command)) + ;;(pop-to-buffer buffer) + (select-window iniwin))) + +(defun cperl-info-on-current-command () + "Show documentation for Perl command at point in other window." + (interactive) + (cperl-info-on-command (cperl-word-at-point))) + +(defun cperl-imenu-info-imenu-search () + (if (looking-at "^-X[ \t\n]") nil + (re-search-backward + "^\n\\([-a-zA-Z_]+\\)[ \t\n]") + (forward-line 1))) + +(defun cperl-imenu-info-imenu-name () + (buffer-substring + (match-beginning 1) (match-end 1))) + +(defun cperl-imenu-on-info () + (interactive) + (let* ((buffer (current-buffer)) + imenu-create-index-function + imenu-prev-index-position-function + imenu-extract-index-name-function + (index-item (save-restriction + (save-window-excursion + (set-buffer (cperl-info-buffer nil)) + (setq imenu-create-index-function + 'imenu-default-create-index-function + imenu-prev-index-position-function + 'cperl-imenu-info-imenu-search + imenu-extract-index-name-function + 'cperl-imenu-info-imenu-name) + (imenu-choose-buffer-index))))) + (and index-item + (progn + (push-mark) + (pop-to-buffer "*info-perl*") + (cond + ((markerp (cdr index-item)) + (goto-char (marker-position (cdr index-item)))) + (t + (goto-char (cdr index-item)))) + (set-window-start (selected-window) (point)) + (pop-to-buffer buffer))))) + +(defun cperl-lineup (beg end &optional step minshift) + "Lineup construction in a region. +Beginning of region should be at the start of a construction. +All first occurrences of this construction in the lines that are +partially contained in the region are lined up at the same column. + +MINSHIFT is the minimal amount of space to insert before the construction. +STEP is the tabwidth to position constructions. +If STEP is nil, `cperl-lineup-step' will be used +\(or `cperl-indent-level', if `cperl-lineup-step' is `nil'). +Will not move the position at the start to the left." + (interactive "r") + (let (search col tcol seen b e) + (save-excursion + (goto-char end) + (end-of-line) + (setq end (point-marker)) + (goto-char beg) + (skip-chars-forward " \t\f") + (setq beg (point-marker)) + (indent-region beg end nil) + (goto-char beg) + (setq col (current-column)) + (if (looking-at "[a-zA-Z0-9_]") + (if (looking-at "\\<[a-zA-Z0-9_]+\\>") + (setq search + (concat "\\<" + (regexp-quote + (buffer-substring (match-beginning 0) + (match-end 0))) "\\>")) + (error "Cannot line up in a middle of the word")) + (if (looking-at "$") + (error "Cannot line up end of line")) + (setq search (regexp-quote (char-to-string (following-char))))) + (setq step (or step cperl-lineup-step cperl-indent-level)) + (or minshift (setq minshift 1)) + (while (progn + (beginning-of-line 2) + (and (< (point) end) + (re-search-forward search end t) + (goto-char (match-beginning 0)))) + (setq tcol (current-column) seen t) + (if (> tcol col) (setq col tcol))) + (or seen + (error "The construction to line up occurred only once")) + (goto-char beg) + (setq col (+ col minshift)) + (if (/= (% col step) 0) (setq step (* step (1+ (/ col step))))) + (while + (progn + (setq e (point)) + (skip-chars-backward " \t") + (delete-region (point) e) + (indent-to-column col) ;(make-string (- col (current-column)) ?\ )) + (beginning-of-line 2) + (and (< (point) end) + (re-search-forward search end t) + (goto-char (match-beginning 0)))))))) ; No body + +(defun cperl-etags (&optional add all files) + "Run etags with appropriate options for Perl files. +If optional argument ALL is `recursive', will process Perl files +in subdirectories too." + (interactive) + (let ((cmd "etags") + (args '("-l" "none" "-r" "/\\<\\(package\\|sub\\)[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)[ \\t]*\\(([^()]*)[ \t]*\\)?\\([{#]\\|$\\)\\)/\\4/")) + res) + (if add (setq args (cons "-a" args))) + (or files (setq files (list buffer-file-name))) + (cond + ((eq all 'recursive) + ;;(error "Not implemented: recursive") + (setq args (append (list "-e" + "sub wanted {push @ARGV, $File::Find::name if /\\.[pP][Llm]$/} + use File::Find; + find(\\&wanted, '.'); + exec @ARGV;" + cmd) args) + cmd "perl")) + (all + ;;(error "Not implemented: all") + (setq args (append (list "-e" + "push @ARGV, <*.PL *.pl *.pm>; + exec @ARGV;" + cmd) args) + cmd "perl")) + (t + (setq args (append args files)))) + (setq res (apply 'call-process cmd nil nil nil args)) + (or (eq res 0) + (message "etags returned \"%s\"" res)))) + +(defun cperl-toggle-auto-newline () + "Toggle the state of `cperl-auto-newline'." + (interactive) + (setq cperl-auto-newline (not cperl-auto-newline)) + (message "Newlines will %sbe auto-inserted now." + (if cperl-auto-newline "" "not "))) + +(defun cperl-toggle-abbrev () + "Toggle the state of automatic keyword expansion in CPerl mode." + (interactive) + (abbrev-mode (if abbrev-mode 0 1)) + (message "Perl control structure will %sbe auto-inserted now." + (if abbrev-mode "" "not "))) + + +(defun cperl-toggle-electric () + "Toggle the state of parentheses doubling in CPerl mode." + (interactive) + (setq cperl-electric-parens (if (cperl-val 'cperl-electric-parens) 'null t)) + (message "Parentheses will %sbe auto-doubled now." + (if (cperl-val 'cperl-electric-parens) "" "not "))) + +(defun cperl-toggle-autohelp () + "Toggle the state of Auto-Help on Perl constructs (put in the message area). +Delay of auto-help controlled by `cperl-lazy-help-time'." + (interactive) + (if (fboundp 'run-with-idle-timer) + (progn + (if cperl-lazy-installed + (cperl-lazy-unstall) + (cperl-lazy-install)) + (message "Perl help messages will %sbe automatically shown now." + (if cperl-lazy-installed "" "not "))) + (message "Cannot automatically show Perl help messages - run-with-idle-timer missing."))) + +(defun cperl-toggle-construct-fix () + "Toggle whether `indent-region'/`indent-sexp' fix whitespace too." + (interactive) + (setq cperl-indent-region-fix-constructs + (if cperl-indent-region-fix-constructs + nil + 1)) + (message "indent-region/indent-sexp will %sbe automatically fix whitespace." + (if cperl-indent-region-fix-constructs "" "not "))) + +;;;; Tags file creation. + +(defvar cperl-tmp-buffer " *cperl-tmp*") + +(defun cperl-setup-tmp-buf () + (set-buffer (get-buffer-create cperl-tmp-buffer)) + (set-syntax-table cperl-mode-syntax-table) + (buffer-disable-undo) + (auto-fill-mode 0) + (if cperl-use-syntax-table-text-property-for-tags + (progn + (make-local-variable 'parse-sexp-lookup-properties) + ;; Do not introduce variable if not needed, we check it! + (set 'parse-sexp-lookup-properties t)))) + +(defun cperl-xsub-scan () + (require 'cl) + (require 'imenu) + (let ((index-alist '()) + (prev-pos 0) index index1 name package prefix) + (goto-char (point-min)) + (if noninteractive + (message "Scanning XSUB for index") + (imenu-progress-message prev-pos 0)) + ;; Search for the function + (progn ;;save-match-data + (while (re-search-forward + "^\\([ \t]*MODULE\\>[^\n]*\\\\|\\([a-zA-Z_][a-zA-Z_0-9]*\\)(\\|[ \t]*BOOT:\\)" + nil t) + (or noninteractive + (imenu-progress-message prev-pos)) + (cond + ((match-beginning 2) ; SECTION + (setq package (buffer-substring (match-beginning 2) (match-end 2))) + (goto-char (match-beginning 0)) + (skip-chars-forward " \t") + (forward-char 1) + (if (looking-at "[^\n]*\\") + (setq prefix (buffer-substring (match-beginning 1) (match-end 1))) + (setq prefix nil))) + ((not package) nil) ; C language section + ((match-beginning 3) ; XSUB + (goto-char (1+ (match-beginning 3))) + (setq index (imenu-example--name-and-position)) + (setq name (buffer-substring (match-beginning 3) (match-end 3))) + (if (and prefix (string-match (concat "^" prefix) name)) + (setq name (substring name (length prefix)))) + (cond ((string-match "::" name) nil) + (t + (setq index1 (cons (concat package "::" name) (cdr index))) + (push index1 index-alist))) + (setcar index name) + (push index index-alist)) + (t ; BOOT: section + ;; (beginning-of-line) + (setq index (imenu-example--name-and-position)) + (setcar index (concat package "::BOOT:")) + (push index index-alist))))) + (or noninteractive + (imenu-progress-message prev-pos 100)) + index-alist)) + +(defvar cperl-unreadable-ok nil) + +(defun cperl-find-tags (ifile xs topdir) + (let ((b (get-buffer cperl-tmp-buffer)) ind lst elt pos ret rel + (cperl-pod-here-fontify nil) f file) + (save-excursion + (if b (set-buffer b) + (cperl-setup-tmp-buf)) + (erase-buffer) + (condition-case err + (setq file (car (insert-file-contents ifile))) + (error (if cperl-unreadable-ok nil + (if (y-or-n-p + (format "File %s unreadable. Continue? " ifile)) + (setq cperl-unreadable-ok t) + (error "Aborting: unreadable file %s" ifile))))) + (if (not file) + (message "Unreadable file %s" ifile) + (message "Scanning file %s ..." file) + (if (and cperl-use-syntax-table-text-property-for-tags + (not xs)) + (condition-case err ; after __END__ may have garbage + (cperl-find-pods-heres nil nil noninteractive) + (error (message "While scanning for syntax: %s" err)))) + (if xs + (setq lst (cperl-xsub-scan)) + (setq ind (cperl-imenu--create-perl-index)) + (setq lst (cdr (assoc "+Unsorted List+..." ind)))) + (setq lst + (mapcar + (function + (lambda (elt) + (cond ((string-match "^[_a-zA-Z]" (car elt)) + (goto-char (cdr elt)) + (beginning-of-line) ; pos should be of the start of the line + (list (car elt) + (point) + (1+ (count-lines 1 (point))) ; 1+ since at beg-o-l + (buffer-substring (progn + (goto-char (cdr elt)) + ;; After name now... + (or (eolp) (forward-char 1)) + (point)) + (progn + (beginning-of-line) + (point)))))))) + lst)) + (erase-buffer) + (while lst + (setq elt (car lst) lst (cdr lst)) + (if elt + (progn + (insert (elt elt 3) + 127 + (if (string-match "^package " (car elt)) + (substring (car elt) 8) + (car elt) ) + 1 + (number-to-string (elt elt 2)) ; Line + "," + (number-to-string (1- (elt elt 1))) ; Char pos 0-based + "\n") + (if (and (string-match "^[_a-zA-Z]+::" (car elt)) + (string-match "^sub[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]" + (elt elt 3))) + ;; Need to insert the name without package as well + (setq lst (cons (cons (substring (elt elt 3) + (match-beginning 1) + (match-end 1)) + (cdr elt)) + lst)))))) + (setq pos (point)) + (goto-char 1) + (setq rel file) + ;; On case-preserving filesystems (EMX on OS/2) case might be encoded in properties + (set-text-properties 0 (length rel) nil rel) + (and (equal topdir (substring rel 0 (length topdir))) + (setq rel (substring file (length topdir)))) + (insert "\f\n" rel "," (number-to-string (1- pos)) "\n") + (setq ret (buffer-substring 1 (point-max))) + (erase-buffer) + (or noninteractive + (message "Scanning file %s finished" file)) + ret)))) + +(defun cperl-add-tags-recurse-noxs () + "Add to TAGS data for Perl and XSUB files in the current directory and kids. +Use as + emacs -batch -q -no-site-file -l emacs/cperl-mode.el \ + -f cperl-add-tags-recurse +" + (cperl-write-tags nil nil t t nil t)) + +(defun cperl-add-tags-recurse () + "Add to TAGS file data for Perl files in the current directory and kids. +Use as + emacs -batch -q -no-site-file -l emacs/cperl-mode.el \ + -f cperl-add-tags-recurse +" + (cperl-write-tags nil nil t t)) + +(defun cperl-write-tags (&optional file erase recurse dir inbuffer noxs topdir) + ;; If INBUFFER, do not select buffer, and do not save + ;; If ERASE is `ignore', do not erase, and do not try to delete old info. + (require 'etags) + (if file nil + (setq file (if dir default-directory (buffer-file-name))) + (if (and (not dir) (buffer-modified-p)) (error "Save buffer first!"))) + (or topdir + (setq topdir default-directory)) + (let ((tags-file-name "TAGS") + (case-fold-search (eq system-type 'emx)) + xs rel tm) + (save-excursion + (cond (inbuffer nil) ; Already there + ((file-exists-p tags-file-name) + (if cperl-xemacs-p + (visit-tags-table-buffer) + (visit-tags-table-buffer tags-file-name))) + (t (set-buffer (find-file-noselect tags-file-name)))) + (cond + (dir + (cond ((eq erase 'ignore)) + (erase + (erase-buffer) + (setq erase 'ignore))) + (let ((files + (condition-case err + (directory-files file t + (if recurse nil cperl-scan-files-regexp) + t) + (error + (if cperl-unreadable-ok nil + (if (y-or-n-p + (format "Directory %s unreadable. Continue? " file)) + (setq cperl-unreadable-ok t + tm nil) ; Return empty list + (error "Aborting: unreadable directory %s" file))))))) + (mapcar (function + (lambda (file) + (cond + ((string-match cperl-noscan-files-regexp file) + nil) + ((not (file-directory-p file)) + (if (string-match cperl-scan-files-regexp file) + (cperl-write-tags file erase recurse nil t noxs topdir))) + ((not recurse) nil) + (t (cperl-write-tags file erase recurse t t noxs topdir))))) + files))) + (t + (setq xs (string-match "\\.xs$" file)) + (if (not (and xs noxs)) + (progn + (cond ((eq erase 'ignore) (goto-char (point-max))) + (erase (erase-buffer)) + (t + (goto-char 1) + (setq rel file) + ;; On case-preserving filesystems (EMX on OS/2) case might be encoded in properties + (set-text-properties 0 (length rel) nil rel) + (and (equal topdir (substring rel 0 (length topdir))) + (setq rel (substring file (length topdir)))) + (if (search-forward (concat "\f\n" rel ",") nil t) + (progn + (search-backward "\f\n") + (delete-region (point) + (save-excursion + (forward-char 1) + (if (search-forward "\f\n" + nil 'toend) + (- (point) 2) + (point-max))))) + (goto-char (point-max))))) + (insert (cperl-find-tags file xs topdir)))))) + (if inbuffer nil ; Delegate to the caller + (save-buffer 0) ; No backup + (if (fboundp 'initialize-new-tags-table) ; Do we need something special in XEmacs? + (initialize-new-tags-table)))))) + +(defvar cperl-tags-hier-regexp-list + (concat + "^\\(" + "\\(package\\)\\>" + "\\|" + "sub\\>[^\n]+::" + "\\|" + "[a-zA-Z_][a-zA-Z_0-9:]*(\C-?[^\n]+::" ; XSUB? + "\\|" + "[ \t]*BOOT:\C-?[^\n]+::" ; BOOT section + "\\)")) + +(defvar cperl-hierarchy '(() ()) + "Global hierarchy of classes.") + +(defun cperl-tags-hier-fill () + ;; Suppose we are in a tag table cooked by cperl. + (goto-char 1) + (let (type pack name pos line chunk ord cons1 file str info fileind) + (while (re-search-forward cperl-tags-hier-regexp-list nil t) + (setq pos (match-beginning 0) + pack (match-beginning 2)) + (beginning-of-line) + (if (looking-at (concat + "\\([^\n]+\\)" + "\C-?" + "\\([^\n]+\\)" + "\C-a" + "\\([0-9]+\\)" + "," + "\\([0-9]+\\)")) + (progn + (setq ;;str (buffer-substring (match-beginning 1) (match-end 1)) + name (buffer-substring (match-beginning 2) (match-end 2)) + ;;pos (buffer-substring (match-beginning 3) (match-end 3)) + line (buffer-substring (match-beginning 3) (match-end 3)) + ord (if pack 1 0) + file (file-of-tag) + fileind (format "%s:%s" file line) + ;; Moves to beginning of the next line: + info (cperl-etags-snarf-tag file line)) + ;; Move back + (forward-char -1) + ;; Make new member of hierarchy name ==> file ==> pos if needed + (if (setq cons1 (assoc name (nth ord cperl-hierarchy))) + ;; Name known + (setcdr cons1 (cons (cons fileind (vector file info)) + (cdr cons1))) + ;; First occurrence of the name, start alist + (setq cons1 (cons name (list (cons fileind (vector file info))))) + (if pack + (setcar (cdr cperl-hierarchy) + (cons cons1 (nth 1 cperl-hierarchy))) + (setcar cperl-hierarchy + (cons cons1 (car cperl-hierarchy))))))) + (end-of-line)))) + +(defun cperl-tags-hier-init (&optional update) + "Show hierarchical menu of classes and methods. +Finds info about classes by a scan of loaded TAGS files. +Supposes that the TAGS files contain fully qualified function names. +One may build such TAGS files from CPerl mode menu." + (interactive) + (require 'etags) + (require 'imenu) + (if (or update (null (nth 2 cperl-hierarchy))) + (let ((remover (function (lambda (elt) ; (name (file1...) (file2..)) + (or (nthcdr 2 elt) + ;; Only in one file + (setcdr elt (cdr (nth 1 elt))))))) + pack name cons1 to l1 l2 l3 l4 b) + ;; (setq cperl-hierarchy '(() () ())) ; Would write into '() later! + (setq cperl-hierarchy (list l1 l2 l3)) + (if cperl-xemacs-p ; Not checked + (progn + (or tags-file-name + ;; Does this work in XEmacs? + (call-interactively 'visit-tags-table)) + (message "Updating list of classes...") + (set-buffer (get-file-buffer tags-file-name)) + (cperl-tags-hier-fill)) + (or tags-table-list + (call-interactively 'visit-tags-table)) + (mapcar + (function + (lambda (tagsfile) + (message "Updating list of classes... %s" tagsfile) + (set-buffer (get-file-buffer tagsfile)) + (cperl-tags-hier-fill))) + tags-table-list) + (message "Updating list of classes... postprocessing...")) + (mapcar remover (car cperl-hierarchy)) + (mapcar remover (nth 1 cperl-hierarchy)) + (setq to (list nil (cons "Packages: " (nth 1 cperl-hierarchy)) + (cons "Methods: " (car cperl-hierarchy)))) + (cperl-tags-treeify to 1) + (setcar (nthcdr 2 cperl-hierarchy) + (cperl-menu-to-keymap (cons '("+++UPDATE+++" . -999) (cdr to)))) + (message "Updating list of classes: done, requesting display...") + ;;(cperl-imenu-addback (nth 2 cperl-hierarchy)) + )) + (or (nth 2 cperl-hierarchy) + (error "No items found")) + (setq update +;;; (imenu-choose-buffer-index "Packages: " (nth 2 cperl-hierarchy)) + (if (if (boundp 'display-popup-menus-p) + (let ((f 'display-popup-menus-p)) + (funcall f)) + window-system) + (x-popup-menu t (nth 2 cperl-hierarchy)) + (require 'tmm) + (tmm-prompt (nth 2 cperl-hierarchy)))) + (if (and update (listp update)) + (progn (while (cdr update) (setq update (cdr update))) + (setq update (car update)))) ; Get the last from the list + (if (vectorp update) + (progn + (find-file (elt update 0)) + (cperl-etags-goto-tag-location (elt update 1)))) + (if (eq update -999) (cperl-tags-hier-init t))) + +(defun cperl-tags-treeify (to level) + ;; cadr of `to' is read-write. On start it is a cons + (let* ((regexp (concat "^\\(" (mapconcat + 'identity + (make-list level "[_a-zA-Z0-9]+") + "::") + "\\)\\(::\\)?")) + (packages (cdr (nth 1 to))) + (methods (cdr (nth 2 to))) + l1 head tail cons1 cons2 ord writeto packs recurse + root-packages root-functions ms many_ms same_name ps + (move-deeper + (function + (lambda (elt) + (cond ((and (string-match regexp (car elt)) + (or (eq ord 1) (match-end 2))) + (setq head (substring (car elt) 0 (match-end 1)) + tail (if (match-end 2) (substring (car elt) + (match-end 2))) + recurse t) + (if (setq cons1 (assoc head writeto)) nil + ;; Need to init new head + (setcdr writeto (cons (list head (list "Packages: ") + (list "Methods: ")) + (cdr writeto))) + (setq cons1 (nth 1 writeto))) + (setq cons2 (nth ord cons1)) ; Either packs or meths + (setcdr cons2 (cons elt (cdr cons2)))) + ((eq ord 2) + (setq root-functions (cons elt root-functions))) + (t + (setq root-packages (cons elt root-packages)))))))) + (setcdr to l1) ; Init to dynamic space + (setq writeto to) + (setq ord 1) + (mapcar move-deeper packages) + (setq ord 2) + (mapcar move-deeper methods) + (if recurse + (mapcar (function (lambda (elt) + (cperl-tags-treeify elt (1+ level)))) + (cdr to))) + ;;Now clean up leaders with one child only + (mapcar (function (lambda (elt) + (if (not (and (listp (cdr elt)) + (eq (length elt) 2))) nil + (setcar elt (car (nth 1 elt))) + (setcdr elt (cdr (nth 1 elt)))))) + (cdr to)) + ;; Sort the roots of subtrees + (if (default-value 'imenu-sort-function) + (setcdr to + (sort (cdr to) (default-value 'imenu-sort-function)))) + ;; Now add back functions removed from display + (mapcar (function (lambda (elt) + (setcdr to (cons elt (cdr to))))) + (if (default-value 'imenu-sort-function) + (nreverse + (sort root-functions (default-value 'imenu-sort-function))) + root-functions)) + ;; Now add back packages removed from display + (mapcar (function (lambda (elt) + (setcdr to (cons (cons (concat "package " (car elt)) + (cdr elt)) + (cdr to))))) + (if (default-value 'imenu-sort-function) + (nreverse + (sort root-packages (default-value 'imenu-sort-function))) + root-packages)))) + +;;;(x-popup-menu t +;;; '(keymap "Name1" +;;; ("Ret1" "aa") +;;; ("Head1" "ab" +;;; keymap "Name2" +;;; ("Tail1" "x") ("Tail2" "y")))) + +(defun cperl-list-fold (list name limit) + (let (list1 list2 elt1 (num 0)) + (if (<= (length list) limit) list + (setq list1 nil list2 nil) + (while list + (setq num (1+ num) + elt1 (car list) + list (cdr list)) + (if (<= num imenu-max-items) + (setq list2 (cons elt1 list2)) + (setq list1 (cons (cons name + (nreverse list2)) + list1) + list2 (list elt1) + num 1))) + (nreverse (cons (cons name + (nreverse list2)) + list1))))) + +(defun cperl-menu-to-keymap (menu &optional name) + (let (list) + (cons 'keymap + (mapcar + (function + (lambda (elt) + (cond ((listp (cdr elt)) + (setq list (cperl-list-fold + (cdr elt) (car elt) imenu-max-items)) + (cons nil + (cons (car elt) + (cperl-menu-to-keymap list)))) + (t + (list (cdr elt) (car elt) t))))) ; t is needed in 19.34 + (cperl-list-fold menu "Root" imenu-max-items))))) + + +(defvar cperl-bad-style-regexp + (mapconcat 'identity + '("[^-\n\t <>=+!.&|(*/'`\"#^][-=+<>!|&^]" ; char sign + "[-<>=+^&|]+[^- \t\n=+<>~]") ; sign+ char + "\\|") + "Finds places such that insertion of a whitespace may help a lot.") + +(defvar cperl-not-bad-style-regexp + (mapconcat + 'identity + '("[^-\t <>=+]\\(--\\|\\+\\+\\)" ; var-- var++ + "[a-zA-Z0-9_][|&][a-zA-Z0-9_$]" ; abc|def abc&def are often used. + "&[(a-zA-Z0-9_$]" ; &subroutine &(var->field) + "<\\$?\\sw+\\(\\.\\sw+\\)?>" ; + "-[a-zA-Z][ \t]+[_$\"'`a-zA-Z]" ; -f file, -t STDIN + "-[0-9]" ; -5 + "\\+\\+" ; ++var + "--" ; --var + ".->" ; a->b + "->" ; a SPACE ->b + "\\[-" ; a[-1] + "\\\\[&$@*\\\\]" ; \&func + "^=" ; =head + "\\$." ; $| + "<<[a-zA-Z_'\"`]" ; <" ; C + "-[a-zA-Z_0-9]+[ \t]*=>" ; -option => value + ;; Unaddressed trouble spots: = -abc, f(56, -abc) --- specialcased below + ;;"[*/+-|&<.]+=" + ) + "\\|") + "If matches at the start of match found by `my-bad-c-style-regexp', +insertion of a whitespace will not help.") + +(defvar found-bad) + +(defun cperl-find-bad-style () + "Find places in the buffer where insertion of a whitespace may help. +Prompts user for insertion of spaces. +Currently it is tuned to C and Perl syntax." + (interactive) + (let (found-bad (p (point))) + (setq last-nonmenu-event 13) ; To disable popup + (beginning-of-buffer) + (map-y-or-n-p "Insert space here? " + (lambda (arg) (insert " ")) + 'cperl-next-bad-style + '("location" "locations" "insert a space into") + '((?\C-r (lambda (arg) + (let ((buffer-quit-function + 'exit-recursive-edit)) + (message "Exit with Esc Esc") + (recursive-edit) + t)) ; Consider acted upon + "edit, exit with Esc Esc") + (?e (lambda (arg) + (let ((buffer-quit-function + 'exit-recursive-edit)) + (message "Exit with Esc Esc") + (recursive-edit) + t)) ; Consider acted upon + "edit, exit with Esc Esc")) + t) + (if found-bad (goto-char found-bad) + (goto-char p) + (message "No appropriate place found")))) + +(defun cperl-next-bad-style () + (let (p (not-found t) (point (point)) found) + (while (and not-found + (re-search-forward cperl-bad-style-regexp nil 'to-end)) + (setq p (point)) + (goto-char (match-beginning 0)) + (if (or + (looking-at cperl-not-bad-style-regexp) + ;; Check for a < -b and friends + (and (eq (following-char) ?\-) + (save-excursion + (skip-chars-backward " \t\n") + (memq (preceding-char) '(?\= ?\> ?\< ?\, ?\( ?\[ ?\{)))) + ;; Now check for syntax type + (save-match-data + (setq found (point)) + (beginning-of-defun) + (let ((pps (parse-partial-sexp (point) found))) + (or (nth 3 pps) (nth 4 pps) (nth 5 pps))))) + (goto-char (match-end 0)) + (goto-char (1- p)) + (setq not-found nil + found-bad found))) + (not not-found))) + + +;;; Getting help +(defvar cperl-have-help-regexp + ;;(concat "\\(" + (mapconcat + 'identity + '("[$@%*&][0-9a-zA-Z_:]+\\([ \t]*[[{]\\)?" ; Usual variable + "[$@]\\^[a-zA-Z]" ; Special variable + "[$@][^ \n\t]" ; Special variable + "-[a-zA-Z]" ; File test + "\\\\[a-zA-Z0]" ; Special chars + "^=[a-z][a-zA-Z0-9_]*" ; POD sections + "[-!&*+,-./<=>?\\\\^|~]+" ; Operator + "[a-zA-Z_0-9:]+" ; symbol or number + "x=" + "#!") + ;;"\\)\\|\\(" + "\\|") + ;;"\\)" + ;;) + "Matches places in the buffer we can find help for.") + +(defvar cperl-message-on-help-error t) +(defvar cperl-help-from-timer nil) + +(defun cperl-word-at-point-hard () + ;; Does not save-excursion + ;; Get to the something meaningful + (or (eobp) (eolp) (forward-char 1)) + (re-search-backward "[-a-zA-Z0-9_:!&*+,-./<=>?\\\\^|~$%@]" + (save-excursion (beginning-of-line) (point)) + 'to-beg) + ;; (cond + ;; ((or (eobp) (looking-at "[][ \t\n{}();,]")) ; Not at a symbol + ;; (skip-chars-backward " \n\t\r({[]});,") + ;; (or (bobp) (backward-char 1)))) + ;; Try to backtrace + (cond + ((looking-at "[a-zA-Z0-9_:]") ; symbol + (skip-chars-backward "a-zA-Z0-9_:") + (cond + ((and (eq (preceding-char) ?^) ; $^I + (eq (char-after (- (point) 2)) ?\$)) + (forward-char -2)) + ((memq (preceding-char) (append "*$@%&\\" nil)) ; *glob + (forward-char -1)) + ((and (eq (preceding-char) ?\=) + (eq (current-column) 1)) + (forward-char -1))) ; =head1 + (if (and (eq (preceding-char) ?\<) + (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; + (forward-char -1))) + ((and (looking-at "=") (eq (preceding-char) ?x)) ; x= + (forward-char -1)) + ((and (looking-at "\\^") (eq (preceding-char) ?\$)) ; $^I + (forward-char -1)) + ((looking-at "[-!&*+,-./<=>?\\\\^|~]") + (skip-chars-backward "-!&*+,-./<=>?\\\\^|~") + (cond + ((and (eq (preceding-char) ?\$) + (not (eq (char-after (- (point) 2)) ?\$))) ; $- + (forward-char -1)) + ((and (eq (following-char) ?\>) + (string-match "[a-zA-Z0-9_]" (char-to-string (preceding-char))) + (save-excursion + (forward-sexp -1) + (and (eq (preceding-char) ?\<) + (looking-at "\\$?[a-zA-Z0-9_:]+>")))) ; + (search-backward "<")))) + ((and (eq (following-char) ?\$) + (eq (preceding-char) ?\<) + (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; <$fh> + (forward-char -1))) + (if (looking-at cperl-have-help-regexp) + (buffer-substring (match-beginning 0) (match-end 0)))) + +(defun cperl-get-help () + "Get one-line docs on the symbol at the point. +The data for these docs is a little bit obsolete and may be in fact longer +than a line. Your contribution to update/shorten it is appreciated." + (interactive) + (save-match-data ; May be called "inside" query-replace + (save-excursion + (let ((word (cperl-word-at-point-hard))) + (if word + (if (and cperl-help-from-timer ; Bail out if not in mainland + (not (string-match "^#!\\|\\\\\\|^=" word)) ; Show help even in comments/strings. + (or (memq (get-text-property (point) 'face) + '(font-lock-comment-face font-lock-string-face)) + (memq (get-text-property (point) 'syntax-type) + '(pod here-doc format)))) + nil + (cperl-describe-perl-symbol word)) + (if cperl-message-on-help-error + (message "Nothing found for %s..." + (buffer-substring (point) (min (+ 5 (point)) (point-max)))))))))) + +;;; Stolen from perl-descr.el by Johan Vromans: + +(defvar cperl-doc-buffer " *perl-doc*" + "Where the documentation can be found.") + +(defun cperl-describe-perl-symbol (val) + "Display the documentation of symbol at point, a Perl operator." + (let ((enable-recursive-minibuffers t) + args-file regexp) + (cond + ((string-match "^[&*][a-zA-Z_]" val) + (setq val (concat (substring val 0 1) "NAME"))) + ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*\\[" val) + (setq val (concat "@" (substring val 1 (match-end 1))))) + ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*{" val) + (setq val (concat "%" (substring val 1 (match-end 1))))) + ((and (string= val "x") (string-match "^x=" val)) + (setq val "x=")) + ((string-match "^\\$[\C-a-\C-z]" val) + (setq val (concat "$^" (char-to-string (+ ?A -1 (aref val 1)))))) + ((string-match "^CORE::" val) + (setq val "CORE::")) + ((string-match "^SUPER::" val) + (setq val "SUPER::")) + ((and (string= "<" val) (string-match "^<\\$?[a-zA-Z0-9_:]+>" val)) + (setq val ""))) + (setq regexp (concat "^" + "\\([^a-zA-Z0-9_:]+[ \t]+\\)?" + (regexp-quote val) + "\\([ \t([/]\\|$\\)")) + + ;; get the buffer with the documentation text + (cperl-switch-to-doc-buffer) + + ;; lookup in the doc + (goto-char (point-min)) + (let ((case-fold-search nil)) + (list + (if (re-search-forward regexp (point-max) t) + (save-excursion + (beginning-of-line 1) + (let ((lnstart (point))) + (end-of-line) + (message "%s" (buffer-substring lnstart (point))))) + (if cperl-message-on-help-error + (message "No definition for %s" val))))))) + +(defvar cperl-short-docs 'please-ignore-this-line + ;; Perl4 version was written by Johan Vromans (jvromans@squirrel.nl) + "# based on '@(#)@ perl-descr.el 1.9 - describe-perl-symbol' [Perl 5] +... Range (list context); flip/flop [no flop when flip] (scalar context). +! ... Logical negation. +... != ... Numeric inequality. +... !~ ... Search pattern, substitution, or translation (negated). +$! In numeric context: errno. In a string context: error string. +$\" The separator which joins elements of arrays interpolated in strings. +$# The output format for printed numbers. Default is %.15g or close. +$$ Process number of this script. Changes in the fork()ed child process. +$% The current page number of the currently selected output channel. + + The following variables are always local to the current block: + +$1 Match of the 1st set of parentheses in the last match (auto-local). +$2 Match of the 2nd set of parentheses in the last match (auto-local). +$3 Match of the 3rd set of parentheses in the last match (auto-local). +$4 Match of the 4th set of parentheses in the last match (auto-local). +$5 Match of the 5th set of parentheses in the last match (auto-local). +$6 Match of the 6th set of parentheses in the last match (auto-local). +$7 Match of the 7th set of parentheses in the last match (auto-local). +$8 Match of the 8th set of parentheses in the last match (auto-local). +$9 Match of the 9th set of parentheses in the last match (auto-local). +$& The string matched by the last pattern match (auto-local). +$' The string after what was matched by the last match (auto-local). +$` The string before what was matched by the last match (auto-local). + +$( The real gid of this process. +$) The effective gid of this process. +$* Deprecated: Set to 1 to do multiline matching within a string. +$+ The last bracket matched by the last search pattern. +$, The output field separator for the print operator. +$- The number of lines left on the page. +$. The current input line number of the last filehandle that was read. +$/ The input record separator, newline by default. +$0 Name of the file containing the current perl script (read/write). +$: String may be broken after these characters to fill ^-lines in a format. +$; Subscript separator for multi-dim array emulation. Default \"\\034\". +$< The real uid of this process. +$= The page length of the current output channel. Default is 60 lines. +$> The effective uid of this process. +$? The status returned by the last ``, pipe close or `system'. +$@ The perl error message from the last eval or do @var{EXPR} command. +$ARGV The name of the current file used with <> . +$[ Deprecated: The index of the first element/char in an array/string. +$\\ The output record separator for the print operator. +$] The perl version string as displayed with perl -v. +$^ The name of the current top-of-page format. +$^A The current value of the write() accumulator for format() lines. +$^D The value of the perl debug (-D) flags. +$^E Information about the last system error other than that provided by $!. +$^F The highest system file descriptor, ordinarily 2. +$^H The current set of syntax checks enabled by `use strict'. +$^I The value of the in-place edit extension (perl -i option). +$^L What formats output to perform a formfeed. Default is \f. +$^M A buffer for emergency memory allocation when running out of memory. +$^O The operating system name under which this copy of Perl was built. +$^P Internal debugging flag. +$^T The time the script was started. Used by -A/-M/-C file tests. +$^W True if warnings are requested (perl -w flag). +$^X The name under which perl was invoked (argv[0] in C-speech). +$_ The default input and pattern-searching space. +$| Auto-flush after write/print on current output channel? Default 0. +$~ The name of the current report format. +... % ... Modulo division. +... %= ... Modulo division assignment. +%ENV Contains the current environment. +%INC List of files that have been require-d or do-ne. +%SIG Used to set signal handlers for various signals. +... & ... Bitwise and. +... && ... Logical and. +... &&= ... Logical and assignment. +... &= ... Bitwise and assignment. +... * ... Multiplication. +... ** ... Exponentiation. +*NAME Glob: all objects refered by NAME. *NAM1 = *NAM2 aliases NAM1 to NAM2. +&NAME(arg0, ...) Subroutine call. Arguments go to @_. +... + ... Addition. +EXPR Makes EXPR into scalar context. +++ Auto-increment (magical on strings). ++EXPR EXPR++ +... += ... Addition assignment. +, Comma operator. +... - ... Subtraction. +-- Auto-decrement (NOT magical on strings). --EXPR EXPR-- +... -= ... Subtraction assignment. +-A Access time in days since script started. +-B File is a non-text (binary) file. +-C Inode change time in days since script started. +-M Age in days since script started. +-O File is owned by real uid. +-R File is readable by real uid. +-S File is a socket . +-T File is a text file. +-W File is writable by real uid. +-X File is executable by real uid. +-b File is a block special file. +-c File is a character special file. +-d File is a directory. +-e File exists . +-f File is a plain file. +-g File has setgid bit set. +-k File has sticky bit set. +-l File is a symbolic link. +-o File is owned by effective uid. +-p File is a named pipe (FIFO). +-r File is readable by effective uid. +-s File has non-zero size. +-t Tests if filehandle (STDIN by default) is opened to a tty. +-u File has setuid bit set. +-w File is writable by effective uid. +-x File is executable by effective uid. +-z File has zero size. +. Concatenate strings. +.. Range (list context); flip/flop (scalar context) operator. +.= Concatenate assignment strings +... / ... Division. /PATTERN/ioxsmg Pattern match +... /= ... Division assignment. +/PATTERN/ioxsmg Pattern match. +... < ... Numeric less than. Glob. See , <> as well. + Reads line from filehandle NAME (a bareword or dollar-bareword). + Glob (Unless pattern is bareword/dollar-bareword - see ). +<> Reads line from union of files in @ARGV (= command line) and STDIN. +... << ... Bitwise shift left. << start of HERE-DOCUMENT. +... <= ... Numeric less than or equal to. +... <=> ... Numeric compare. +... = ... Assignment. +... == ... Numeric equality. +... =~ ... Search pattern, substitution, or translation +... > ... Numeric greater than. +... >= ... Numeric greater than or equal to. +... >> ... Bitwise shift right. +... >>= ... Bitwise shift right assignment. +... ? ... : ... Condition=if-then-else operator. ?PAT? One-time pattern match. +?PATTERN? One-time pattern match. +@ARGV Command line arguments (not including the command name - see $0). +@INC List of places to look for perl scripts during do/include/use. +@_ Parameter array for subroutines; result of split() unless in list context. +\\ Creates reference to what follows, like \$var, or quotes non-\w in strings. +\\0 Octal char, e.g. \\033. +\\E Case modification terminator. See \\Q, \\L, and \\U. +\\L Lowercase until \\E . See also \l, lc. +\\U Upcase until \\E . See also \u, uc. +\\Q Quote metacharacters until \\E . See also quotemeta. +\\a Alarm character (octal 007). +\\b Backspace character (octal 010). +\\c Control character, e.g. \\c[ . +\\e Escape character (octal 033). +\\f Formfeed character (octal 014). +\\l Lowercase the next character. See also \\L and \\u, lcfirst. +\\n Newline character (octal 012 on most systems). +\\r Return character (octal 015 on most systems). +\\t Tab character (octal 011). +\\u Upcase the next character. See also \\U and \\l, ucfirst. +\\x Hex character, e.g. \\x1b. +... ^ ... Bitwise exclusive or. +__END__ Ends program source. +__DATA__ Ends program source. +__FILE__ Current (source) filename. +__LINE__ Current line in current source. +__PACKAGE__ Current package. +ARGV Default multi-file input filehandle. is a synonym for <>. +ARGVOUT Output filehandle with -i flag. +BEGIN { ... } Immediately executed (during compilation) piece of code. +END { ... } Pseudo-subroutine executed after the script finishes. +CHECK { ... } Pseudo-subroutine executed after the script is compiled. +INIT { ... } Pseudo-subroutine executed before the script starts running. +DATA Input filehandle for what follows after __END__ or __DATA__. +accept(NEWSOCKET,GENERICSOCKET) +alarm(SECONDS) +atan2(X,Y) +bind(SOCKET,NAME) +binmode(FILEHANDLE) +caller[(LEVEL)] +chdir(EXPR) +chmod(LIST) +chop[(LIST|VAR)] +chown(LIST) +chroot(FILENAME) +close(FILEHANDLE) +closedir(DIRHANDLE) +... cmp ... String compare. +connect(SOCKET,NAME) +continue of { block } continue { block }. Is executed after `next' or at end. +cos(EXPR) +crypt(PLAINTEXT,SALT) +dbmclose(%HASH) +dbmopen(%HASH,DBNAME,MODE) +defined(EXPR) +delete($HASH{KEY}) +die(LIST) +do { ... }|SUBR while|until EXPR executes at least once +do(EXPR|SUBR([LIST])) (with while|until executes at least once) +dump LABEL +each(%HASH) +endgrent +endhostent +endnetent +endprotoent +endpwent +endservent +eof[([FILEHANDLE])] +... eq ... String equality. +eval(EXPR) or eval { BLOCK } +exec(LIST) +exit(EXPR) +exp(EXPR) +fcntl(FILEHANDLE,FUNCTION,SCALAR) +fileno(FILEHANDLE) +flock(FILEHANDLE,OPERATION) +for (EXPR;EXPR;EXPR) { ... } +foreach [VAR] (@ARRAY) { ... } +fork +... ge ... String greater than or equal. +getc[(FILEHANDLE)] +getgrent +getgrgid(GID) +getgrnam(NAME) +gethostbyaddr(ADDR,ADDRTYPE) +gethostbyname(NAME) +gethostent +getlogin +getnetbyaddr(ADDR,ADDRTYPE) +getnetbyname(NAME) +getnetent +getpeername(SOCKET) +getpgrp(PID) +getppid +getpriority(WHICH,WHO) +getprotobyname(NAME) +getprotobynumber(NUMBER) +getprotoent +getpwent +getpwnam(NAME) +getpwuid(UID) +getservbyname(NAME,PROTO) +getservbyport(PORT,PROTO) +getservent +getsockname(SOCKET) +getsockopt(SOCKET,LEVEL,OPTNAME) +gmtime(EXPR) +goto LABEL +... gt ... String greater than. +hex(EXPR) +if (EXPR) { ... } [ elsif (EXPR) { ... } ... ] [ else { ... } ] or EXPR if EXPR +index(STR,SUBSTR[,OFFSET]) +int(EXPR) +ioctl(FILEHANDLE,FUNCTION,SCALAR) +join(EXPR,LIST) +keys(%HASH) +kill(LIST) +last [LABEL] +... le ... String less than or equal. +length(EXPR) +link(OLDFILE,NEWFILE) +listen(SOCKET,QUEUESIZE) +local(LIST) +localtime(EXPR) +log(EXPR) +lstat(EXPR|FILEHANDLE|VAR) +... lt ... String less than. +m/PATTERN/iogsmx +mkdir(FILENAME,MODE) +msgctl(ID,CMD,ARG) +msgget(KEY,FLAGS) +msgrcv(ID,VAR,SIZE,TYPE.FLAGS) +msgsnd(ID,MSG,FLAGS) +my VAR or my (VAR1,...) Introduces a lexical variable ($VAR, @ARR, or %HASH). +our VAR or our (VAR1,...) Lexically enable a global variable ($V, @A, or %H). +... ne ... String inequality. +next [LABEL] +oct(EXPR) +open(FILEHANDLE[,EXPR]) +opendir(DIRHANDLE,EXPR) +ord(EXPR) ASCII value of the first char of the string. +pack(TEMPLATE,LIST) +package NAME Introduces package context. +pipe(READHANDLE,WRITEHANDLE) Create a pair of filehandles on ends of a pipe. +pop(ARRAY) +print [FILEHANDLE] [(LIST)] +printf [FILEHANDLE] (FORMAT,LIST) +push(ARRAY,LIST) +q/STRING/ Synonym for 'STRING' +qq/STRING/ Synonym for \"STRING\" +qx/STRING/ Synonym for `STRING` +rand[(EXPR)] +read(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) +readdir(DIRHANDLE) +readlink(EXPR) +recv(SOCKET,SCALAR,LEN,FLAGS) +redo [LABEL] +rename(OLDNAME,NEWNAME) +require [FILENAME | PERL_VERSION] +reset[(EXPR)] +return(LIST) +reverse(LIST) +rewinddir(DIRHANDLE) +rindex(STR,SUBSTR[,OFFSET]) +rmdir(FILENAME) +s/PATTERN/REPLACEMENT/gieoxsm +scalar(EXPR) +seek(FILEHANDLE,POSITION,WHENCE) +seekdir(DIRHANDLE,POS) +select(FILEHANDLE | RBITS,WBITS,EBITS,TIMEOUT) +semctl(ID,SEMNUM,CMD,ARG) +semget(KEY,NSEMS,SIZE,FLAGS) +semop(KEY,...) +send(SOCKET,MSG,FLAGS[,TO]) +setgrent +sethostent(STAYOPEN) +setnetent(STAYOPEN) +setpgrp(PID,PGRP) +setpriority(WHICH,WHO,PRIORITY) +setprotoent(STAYOPEN) +setpwent +setservent(STAYOPEN) +setsockopt(SOCKET,LEVEL,OPTNAME,OPTVAL) +shift[(ARRAY)] +shmctl(ID,CMD,ARG) +shmget(KEY,SIZE,FLAGS) +shmread(ID,VAR,POS,SIZE) +shmwrite(ID,STRING,POS,SIZE) +shutdown(SOCKET,HOW) +sin(EXPR) +sleep[(EXPR)] +socket(SOCKET,DOMAIN,TYPE,PROTOCOL) +socketpair(SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL) +sort [SUBROUTINE] (LIST) +splice(ARRAY,OFFSET[,LENGTH[,LIST]]) +split[(/PATTERN/[,EXPR[,LIMIT]])] +sprintf(FORMAT,LIST) +sqrt(EXPR) +srand(EXPR) +stat(EXPR|FILEHANDLE|VAR) +study[(SCALAR)] +sub [NAME [(format)]] { BODY } sub NAME [(format)]; sub [(format)] {...} +substr(EXPR,OFFSET[,LEN]) +symlink(OLDFILE,NEWFILE) +syscall(LIST) +sysread(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) +system(LIST) +syswrite(FILEHANDLE,SCALAR,LENGTH[,OFFSET]) +tell[(FILEHANDLE)] +telldir(DIRHANDLE) +time +times +tr/SEARCHLIST/REPLACEMENTLIST/cds +truncate(FILE|EXPR,LENGTH) +umask[(EXPR)] +undef[(EXPR)] +unless (EXPR) { ... } [ else { ... } ] or EXPR unless EXPR +unlink(LIST) +unpack(TEMPLATE,EXPR) +unshift(ARRAY,LIST) +until (EXPR) { ... } EXPR until EXPR +utime(LIST) +values(%HASH) +vec(EXPR,OFFSET,BITS) +wait +waitpid(PID,FLAGS) +wantarray Returns true if the sub/eval is called in list context. +warn(LIST) +while (EXPR) { ... } EXPR while EXPR +write[(EXPR|FILEHANDLE)] +... x ... Repeat string or array. +x= ... Repetition assignment. +y/SEARCHLIST/REPLACEMENTLIST/ +... | ... Bitwise or. +... || ... Logical or. +~ ... Unary bitwise complement. +#! OS interpreter indicator. If contains `perl', used for options, and -x. +AUTOLOAD {...} Shorthand for `sub AUTOLOAD {...}'. +CORE:: Prefix to access builtin function if imported sub obscures it. +SUPER:: Prefix to lookup for a method in @ISA classes. +DESTROY Shorthand for `sub DESTROY {...}'. +... EQ ... Obsolete synonym of `eq'. +... GE ... Obsolete synonym of `ge'. +... GT ... Obsolete synonym of `gt'. +... LE ... Obsolete synonym of `le'. +... LT ... Obsolete synonym of `lt'. +... NE ... Obsolete synonym of `ne'. +abs [ EXPR ] absolute value +... and ... Low-precedence synonym for &&. +bless REFERENCE [, PACKAGE] Makes reference into an object of a package. +chomp [LIST] Strips $/ off LIST/$_. Returns count. Special if $/ eq ''! +chr Converts a number to char with the same ordinal. +else Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}. +elsif Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}. +exists $HASH{KEY} True if the key exists. +format [NAME] = Start of output format. Ended by a single dot (.) on a line. +formline PICTURE, LIST Backdoor into \"format\" processing. +glob EXPR Synonym of . +lc [ EXPR ] Returns lowercased EXPR. +lcfirst [ EXPR ] Returns EXPR with lower-cased first letter. +grep EXPR,LIST or grep {BLOCK} LIST Filters LIST via EXPR/BLOCK. +map EXPR, LIST or map {BLOCK} LIST Applies EXPR/BLOCK to elts of LIST. +no PACKAGE [SYMBOL1, ...] Partial reverse for `use'. Runs `unimport' method. +not ... Low-precedence synonym for ! - negation. +... or ... Low-precedence synonym for ||. +pos STRING Set/Get end-position of the last match over this string, see \\G. +quotemeta [ EXPR ] Quote regexp metacharacters. +qw/WORD1 .../ Synonym of split('', 'WORD1 ...') +readline FH Synonym of . +readpipe CMD Synonym of `CMD`. +ref [ EXPR ] Type of EXPR when dereferenced. +sysopen FH, FILENAME, MODE [, PERM] (MODE is numeric, see Fcntl.) +tie VAR, PACKAGE, LIST Hide an object behind a simple Perl variable. +tied Returns internal object for a tied data. +uc [ EXPR ] Returns upcased EXPR. +ucfirst [ EXPR ] Returns EXPR with upcased first letter. +untie VAR Unlink an object from a simple Perl variable. +use PACKAGE [SYMBOL1, ...] Compile-time `require' with consequent `import'. +... xor ... Low-precedence synonym for exclusive or. +prototype \&SUB Returns prototype of the function given a reference. +=head1 Top-level heading. +=head2 Second-level heading. +=head3 Third-level heading (is there such?). +=over [ NUMBER ] Start list. +=item [ TITLE ] Start new item in the list. +=back End list. +=cut Switch from POD to Perl. +=pod Switch from Perl to POD. +") + +(defun cperl-switch-to-doc-buffer () + "Go to the perl documentation buffer and insert the documentation." + (interactive) + (let ((buf (get-buffer-create cperl-doc-buffer))) + (if (interactive-p) + (switch-to-buffer-other-window buf) + (set-buffer buf)) + (if (= (buffer-size) 0) + (progn + (insert (documentation-property 'cperl-short-docs + 'variable-documentation)) + (setq buffer-read-only t))))) + +(defun cperl-beautify-regexp-piece (b e embed level) + ;; b is before the starting delimiter, e before the ending + ;; e should be a marker, may be changed, but remains "correct". + ;; EMBED is nil iff we process the whole REx. + ;; The REx is guarantied to have //x + ;; LEVEL shows how many levels deep to go + ;; position at enter and at leave is not defined + (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline code pos) + (if (not embed) + (goto-char (1+ b)) + (goto-char b) + (cond ((looking-at "(\\?\\\\#") ; (?#) wrongly commented when //x-ing + (forward-char 2) + (delete-char 1) + (forward-char 1)) + ((looking-at "(\\?[^a-zA-Z]") + (forward-char 3)) + ((looking-at "(\\?") ; (?i) + (forward-char 2)) + (t + (forward-char 1)))) + (setq c (if embed (current-indentation) (1- (current-column))) + c1 (+ c (or cperl-regexp-indent-step cperl-indent-level))) + (or (looking-at "[ \t]*[\n#]") + (progn + (insert "\n"))) + (goto-char e) + (beginning-of-line) + (if (re-search-forward "[^ \t]" e t) + (progn ; Something before the ending delimiter + (goto-char e) + (delete-horizontal-space) + (insert "\n") + (indent-to-column c) + (set-marker e (point)))) + (goto-char b) + (end-of-line 2) + (while (< (point) (marker-position e)) + (beginning-of-line) + (setq s (point) + inline t) + (skip-chars-forward " \t") + (delete-region s (point)) + (indent-to-column c1) + (while (and + inline + (looking-at + (concat "\\([a-zA-Z0-9]+[^*+{?]\\)" ; 1 word + "\\|" ; Embedded variable + "\\$\\([a-zA-Z0-9_]+\\([[{]\\)?\\|[^\n \t)|]\\)" ; 2 3 + "\\|" ; $ ^ + "[$^]" + "\\|" ; simple-code simple-code*? + "\\(\\\\.\\|[^][()#|*+?\n]\\)\\([*+{?]\\??\\)?" ; 4 5 + "\\|" ; Class + "\\(\\[\\)" ; 6 + "\\|" ; Grouping + "\\((\\(\\?\\)?\\)" ; 7 8 + "\\|" ; | + "\\(|\\)"))) ; 9 + (goto-char (match-end 0)) + (setq spaces t) + (cond ((match-beginning 1) ; Alphanum word + junk + (forward-char -1)) + ((or (match-beginning 3) ; $ab[12] + (and (match-beginning 5) ; X* X+ X{2,3} + (eq (preceding-char) ?\{))) + (forward-char -1) + (forward-sexp 1)) + ((match-beginning 6) ; [] + (setq tmp (point)) + (if (looking-at "\\^?\\]") + (goto-char (match-end 0))) + ;; XXXX POSIX classes?! + (while (and (not pos) + (re-search-forward "\\[:\\|\\]" e t)) + (if (eq (preceding-char) ?:) + (or (re-search-forward ":\\]" e t) + (error "[:POSIX:]-group in []-group not terminated")) + (setq pos t))) + (or (eq (preceding-char) ?\]) + (error "[]-group not terminated")) + (if (eq (following-char) ?\{) + (progn + (forward-sexp 1) + (and (eq (following-char) ??) + (forward-char 1))) + (re-search-forward "\\=\\([*+?]\\??\\)" e t))) + ((match-beginning 7) ; () + (goto-char (match-beginning 0)) + (setq pos (current-column)) + (or (eq pos c1) + (progn + (delete-horizontal-space) + (insert "\n") + (indent-to-column c1))) + (setq tmp (point)) + (forward-sexp 1) + ;; (or (forward-sexp 1) + ;; (progn + ;; (goto-char tmp) + ;; (error "()-group not terminated"))) + (set-marker m (1- (point))) + (set-marker m1 (point)) + (if (= level 1) + (if (progn ; indent rigidly if multiline + ;; In fact does not make a lot of sense, since + ;; the starting position can be already lost due + ;; to insertion of "\n" and " " + (goto-char tmp) + (search-forward "\n" m1 t)) + (indent-rigidly (point) m1 (- c1 pos))) + (setq level (1- level)) + (cond + ((not (match-beginning 8)) + (cperl-beautify-regexp-piece tmp m t level)) + ((eq (char-after (+ 2 tmp)) ?\{) ; Code + t) + ((eq (char-after (+ 2 tmp)) ?\() ; Conditional + (goto-char (+ 2 tmp)) + (forward-sexp 1) + (cperl-beautify-regexp-piece (point) m t level)) + ((eq (char-after (+ 2 tmp)) ?<) ; Lookbehind + (goto-char (+ 3 tmp)) + (cperl-beautify-regexp-piece (point) m t level)) + (t + (cperl-beautify-regexp-piece tmp m t level)))) + (goto-char m1) + (cond ((looking-at "[*+?]\\??") + (goto-char (match-end 0))) + ((eq (following-char) ?\{) + (forward-sexp 1) + (if (eq (following-char) ?\?) + (forward-char)))) + (skip-chars-forward " \t") + (setq spaces nil) + (if (looking-at "[#\n]") + (progn + (or (eolp) (indent-for-comment)) + (beginning-of-line 2)) + (delete-horizontal-space) + (insert "\n")) + (end-of-line) + (setq inline nil)) + ((match-beginning 9) ; | + (forward-char -1) + (setq tmp (point)) + (beginning-of-line) + (if (re-search-forward "[^ \t]" tmp t) + (progn + (goto-char tmp) + (delete-horizontal-space) + (insert "\n")) + ;; first at line + (delete-region (point) tmp)) + (indent-to-column c) + (forward-char 1) + (skip-chars-forward " \t") + (setq spaces nil) + (if (looking-at "[#\n]") + (beginning-of-line 2) + (delete-horizontal-space) + (insert "\n")) + (end-of-line) + (setq inline nil))) + (or (looking-at "[ \t\n]") + (not spaces) + (insert " ")) + (skip-chars-forward " \t")) + (or (looking-at "[#\n]") + (error "Unknown code `%s' in a regexp" + (buffer-substring (point) (1+ (point))))) + (and inline (end-of-line 2))) + ;; Special-case the last line of group + (if (and (>= (point) (marker-position e)) + (/= (current-indentation) c)) + (progn + (beginning-of-line) + (setq s (point)) + (skip-chars-forward " \t") + (delete-region s (point)) + (indent-to-column c))))) + +(defun cperl-make-regexp-x () + ;; Returns position of the start + ;; XXX this is called too often! Need to cache the result! + (save-excursion + (or cperl-use-syntax-table-text-property + (error "I need to have a regexp marked!")) + ;; Find the start + (if (looking-at "\\s|") + nil ; good already + (if (looking-at "\\([smy]\\|qr\\)\\s|") + (forward-char 1) + (re-search-backward "\\s|"))) ; Assume it is scanned already. + ;;(forward-char 1) + (let ((b (point)) (e (make-marker)) have-x delim (c (current-column)) + (sub-p (eq (preceding-char) ?s)) s) + (forward-sexp 1) + (set-marker e (1- (point))) + (setq delim (preceding-char)) + (if (and sub-p (eq delim (char-after (- (point) 2)))) + (error "Possible s/blah// - do not know how to deal with")) + (if sub-p (forward-sexp 1)) + (if (looking-at "\\sw*x") + (setq have-x t) + (insert "x")) + ;; Protect fragile " ", "#" + (if have-x nil + (goto-char (1+ b)) + (while (re-search-forward "\\(\\=\\|[^\\\\]\\)\\(\\\\\\\\\\)*[ \t\n#]" e t) ; Need to include (?#) too? + (forward-char -1) + (insert "\\") + (forward-char 1))) + b))) + +(defun cperl-beautify-regexp (&optional deep) + "Do it. (Experimental, may change semantics, recheck the result.) +We suppose that the regexp is scanned already." + (interactive "P") + (setq deep (if deep (prefix-numeric-value deep) -1)) + (save-excursion + (goto-char (cperl-make-regexp-x)) + (let ((b (point)) (e (make-marker))) + (forward-sexp 1) + (set-marker e (1- (point))) + (cperl-beautify-regexp-piece b e nil deep)))) + +(defun cperl-regext-to-level-start () + "Goto start of an enclosing group in regexp. +We suppose that the regexp is scanned already." + (interactive) + (let ((limit (cperl-make-regexp-x)) done) + (while (not done) + (or (eq (following-char) ?\() + (search-backward "(" (1+ limit) t) + (error "Cannot find `(' which starts a group")) + (setq done + (save-excursion + (skip-chars-backward "\\") + (looking-at "\\(\\\\\\\\\\)*("))) + (or done (forward-char -1))))) + +(defun cperl-contract-level () + "Find an enclosing group in regexp and contract it. +\(Experimental, may change semantics, recheck the result.) +We suppose that the regexp is scanned already." + (interactive) + ;; (save-excursion ; Can't, breaks `cperl-contract-levels' + (cperl-regext-to-level-start) + (let ((b (point)) (e (make-marker)) s c) + (forward-sexp 1) + (set-marker e (1- (point))) + (goto-char b) + (while (re-search-forward "\\(#\\)\\|\n" e 'to-end) + (cond + ((match-beginning 1) ; #-comment + (or c (setq c (current-indentation))) + (beginning-of-line 2) ; Skip + (setq s (point)) + (skip-chars-forward " \t") + (delete-region s (point)) + (indent-to-column c)) + (t + (delete-char -1) + (just-one-space)))))) + +(defun cperl-contract-levels () + "Find an enclosing group in regexp and contract all the kids. +\(Experimental, may change semantics, recheck the result.) +We suppose that the regexp is scanned already." + (interactive) + (save-excursion + (condition-case nil + (cperl-regext-to-level-start) + (error ; We are outside outermost group + (goto-char (cperl-make-regexp-x)))) + (let ((b (point)) (e (make-marker)) s c) + (forward-sexp 1) + (set-marker e (1- (point))) + (goto-char (1+ b)) + (while (re-search-forward "\\(\\\\\\\\\\)\\|(" e t) + (cond + ((match-beginning 1) ; Skip + nil) + (t ; Group + (cperl-contract-level))))))) + +(defun cperl-beautify-level (&optional deep) + "Find an enclosing group in regexp and beautify it. +\(Experimental, may change semantics, recheck the result.) +We suppose that the regexp is scanned already." + (interactive "P") + (setq deep (if deep (prefix-numeric-value deep) -1)) + (save-excursion + (cperl-regext-to-level-start) + (let ((b (point)) (e (make-marker))) + (forward-sexp 1) + (set-marker e (1- (point))) + (cperl-beautify-regexp-piece b e nil deep)))) + +(defun cperl-invert-if-unless () + "Change `if (A) {B}' into `B if A;' etc if possible." + (interactive) + (or (looking-at "\\<") + (forward-sexp -1)) + (if (looking-at "\\<\\(if\\|unless\\|while\\|until\\|for\\|foreach\\)\\>") + (let ((pos1 (point)) + pos2 pos3 pos4 pos5 s1 s2 state p pos45 + (s0 (buffer-substring (match-beginning 0) (match-end 0)))) + (forward-sexp 2) + (setq pos3 (point)) + (forward-sexp -1) + (setq pos2 (point)) + (if (eq (following-char) ?\( ) + (progn + (goto-char pos3) + (forward-sexp 1) + (setq pos5 (point)) + (forward-sexp -1) + (setq pos4 (point)) + ;; XXXX In fact may be `A if (B); {C}' ... + (if (and (eq (following-char) ?\{ ) + (progn + (cperl-backward-to-noncomment pos3) + (eq (preceding-char) ?\) ))) + (if (condition-case nil + (progn + (goto-char pos5) + (forward-sexp 1) + (forward-sexp -1) + (looking-at "\\")) + (error nil)) + (error + "`%s' (EXPR) {BLOCK} with `else'/`elsif'" s0) + (goto-char (1- pos5)) + (cperl-backward-to-noncomment pos4) + (if (eq (preceding-char) ?\;) + (forward-char -1)) + (setq pos45 (point)) + (goto-char pos4) + (while (re-search-forward "\\<\\(for\\|foreach\\|if\\|unless\\|while\\|until\\)\\>\\|;" pos45 t) + (setq p (match-beginning 0) + s1 (buffer-substring p (match-end 0)) + state (parse-partial-sexp pos4 p)) + (or (nth 3 state) + (nth 4 state) + (nth 5 state) + (error "`%s' inside `%s' BLOCK" s1 s0)) + (goto-char (match-end 0))) + ;; Finally got it + (goto-char (1+ pos4)) + (skip-chars-forward " \t\n") + (setq s2 (buffer-substring (point) pos45)) + (goto-char pos45) + (or (looking-at ";?[ \t\n]*}") + (progn + (skip-chars-forward "; \t\n") + (setq s2 (concat s2 "\n" (buffer-substring (point) (1- pos5)))))) + (and (equal s2 "") + (setq s2 "1")) + (goto-char (1- pos3)) + (cperl-backward-to-noncomment pos2) + (or (looking-at "[ \t\n]*)") + (goto-char (1- pos3))) + (setq p (point)) + (goto-char (1+ pos2)) + (skip-chars-forward " \t\n") + (setq s1 (buffer-substring (point) p)) + (delete-region pos4 pos5) + (delete-region pos2 pos3) + (goto-char pos1) + (insert s2 " ") + (just-one-space) + (forward-word 1) + (setq pos1 (point)) + (insert " " s1 ";") + (delete-horizontal-space) + (forward-char -1) + (delete-horizontal-space) + (goto-char pos1) + (just-one-space) + (cperl-indent-line)) + (error "`%s' (EXPR) not with an {BLOCK}" s0))) + (error "`%s' not with an (EXPR)" s0))) + (error "Not at `if', `unless', `while', `until', `for' or `foreach'"))) + +;;; By Anthony Foiani +;;; Getting help on modules in C-h f ? +;;; This is a modified version of `man'. +;;; Need to teach it how to lookup functions +(defun cperl-perldoc (word) + "Run `perldoc' on WORD." + (interactive + (list (let* ((default-entry (cperl-word-at-point)) + (input (read-string + (format "perldoc entry%s: " + (if (string= default-entry "") + "" + (format " (default %s)" default-entry)))))) + (if (string= input "") + (if (string= default-entry "") + (error "No perldoc args given") + default-entry) + input)))) + (require 'man) + (let* ((case-fold-search nil) + (is-func (and + (string-match "^[a-z]+$" word) + (string-match (concat "^" word "\\>") + (documentation-property + 'cperl-short-docs + 'variable-documentation)))) + (manual-program (if is-func "perldoc -f" "perldoc"))) + (cond + (cperl-xemacs-p + (let ((Manual-program "perldoc") + (Manual-switches (if is-func (list "-f")))) + (manual-entry word))) + (t + (Man-getpage-in-background word))))) + +(defun cperl-perldoc-at-point () + "Run a `perldoc' on the word around point." + (interactive) + (cperl-perldoc (cperl-word-at-point))) + +(defcustom pod2man-program "pod2man" + "*File name for `pod2man'." + :type 'file + :group 'cperl) + +;;; By Nick Roberts (with changes) +(defun cperl-pod-to-manpage () + "Create a virtual manpage in Emacs from the Perl Online Documentation." + (interactive) + (require 'man) + (let* ((pod2man-args (concat buffer-file-name " | nroff -man ")) + (bufname (concat "Man " buffer-file-name)) + (buffer (generate-new-buffer bufname))) + (save-excursion + (set-buffer buffer) + (let ((process-environment (copy-sequence process-environment))) + ;; Prevent any attempt to use display terminal fanciness. + (setenv "TERM" "dumb") + (set-process-sentinel + (start-process pod2man-program buffer "sh" "-c" + (format (cperl-pod2man-build-command) pod2man-args)) + 'Man-bgproc-sentinel))))) + +;;; Updated version by him too +(defun cperl-build-manpage () + "Create a virtual manpage in Emacs from the POD in the file." + (interactive) + (require 'man) + (cond + (cperl-xemacs-p + (let ((Manual-program "perldoc")) + (manual-entry buffer-file-name))) + (t + (let* ((manual-program "perldoc")) + (Man-getpage-in-background buffer-file-name))))) + +(defun cperl-pod2man-build-command () + "Builds the entire background manpage and cleaning command." + (let ((command (concat pod2man-program " %s 2>/dev/null")) + (flist Man-filter-list)) + (while (and flist (car flist)) + (let ((pcom (car (car flist))) + (pargs (cdr (car flist)))) + (setq command + (concat command " | " pcom " " + (mapconcat '(lambda (phrase) + (if (not (stringp phrase)) + (error "Malformed Man-filter-list")) + phrase) + pargs " "))) + (setq flist (cdr flist)))) + command)) + +(defun cperl-lazy-install ()) ; Avoid a warning +(defun cperl-lazy-unstall ()) ; Avoid a warning + +(if (fboundp 'run-with-idle-timer) + (progn + (defvar cperl-help-shown nil + "Non-nil means that the help was already shown now.") + + (defvar cperl-lazy-installed nil + "Non-nil means that the lazy-help handlers are installed now.") + + (defun cperl-lazy-install () + "Switches on Auto-Help on Perl constructs (put in the message area). +Delay of auto-help controlled by `cperl-lazy-help-time'." + (interactive) + (make-variable-buffer-local 'cperl-help-shown) + (if (and (cperl-val 'cperl-lazy-help-time) + (not cperl-lazy-installed)) + (progn + (add-hook 'post-command-hook 'cperl-lazy-hook) + (run-with-idle-timer + (cperl-val 'cperl-lazy-help-time 1000000 5) + t + 'cperl-get-help-defer) + (setq cperl-lazy-installed t)))) + + (defun cperl-lazy-unstall () + "Switches off Auto-Help on Perl constructs (put in the message area). +Delay of auto-help controlled by `cperl-lazy-help-time'." + (interactive) + (remove-hook 'post-command-hook 'cperl-lazy-hook) + (cancel-function-timers 'cperl-get-help-defer) + (setq cperl-lazy-installed nil)) + + (defun cperl-lazy-hook () + (setq cperl-help-shown nil)) + + (defun cperl-get-help-defer () + (if (not (memq major-mode '(perl-mode cperl-mode))) nil + (let ((cperl-message-on-help-error nil) (cperl-help-from-timer t)) + (cperl-get-help) + (setq cperl-help-shown t)))) + (cperl-lazy-install))) + + +;;; Plug for wrong font-lock: + +(defun cperl-font-lock-unfontify-region-function (beg end) + (let* ((modified (buffer-modified-p)) (buffer-undo-list t) + (inhibit-read-only t) (inhibit-point-motion-hooks t) + before-change-functions after-change-functions + deactivate-mark buffer-file-name buffer-file-truename) + (remove-text-properties beg end '(face nil)) + (when (and (not modified) (buffer-modified-p)) + (set-buffer-modified-p nil)))) + +(defvar cperl-d-l nil) +(defun cperl-fontify-syntaxically (end) + ;; Some vars for debugging only + ;; (message "Syntaxifying...") + (let ((dbg (point)) (iend end) + (istate (car cperl-syntax-state)) + start) + (and cperl-syntaxify-unwind + (setq end (cperl-unwind-to-safe t end))) + (setq start (point)) + (or cperl-syntax-done-to + (setq cperl-syntax-done-to (point-min))) + (if (or (not (boundp 'font-lock-hot-pass)) + (eval 'font-lock-hot-pass) + t) ; Not debugged otherwise + ;; Need to forget what is after `start' + (setq start (min cperl-syntax-done-to start)) + ;; Fontification without a change + (setq start (max cperl-syntax-done-to start))) + (and (> end start) + (setq cperl-syntax-done-to start) ; In case what follows fails + (cperl-find-pods-heres start end t nil t)) + (if (eq cperl-syntaxify-by-font-lock 'message) + (message "Syntaxified %s..%s from %s to %s(%s), state %s-->%s" + dbg iend + start end cperl-syntax-done-to + istate (car cperl-syntax-state))) ; For debugging + nil)) ; Do not iterate + +(defun cperl-fontify-update (end) + (let ((pos (point)) prop posend) + (while (< pos end) + (setq prop (get-text-property pos 'cperl-postpone)) + (setq posend (next-single-property-change pos 'cperl-postpone nil end)) + (and prop (put-text-property pos posend (car prop) (cdr prop))) + (setq pos posend))) + nil) ; Do not iterate + +(defun cperl-update-syntaxification (from to) + (if (and cperl-use-syntax-table-text-property + cperl-syntaxify-by-font-lock + (or (null cperl-syntax-done-to) + (< cperl-syntax-done-to to))) + (progn + (save-excursion + (goto-char from) + (cperl-fontify-syntaxically to))))) + +(defvar cperl-version + (let ((v "$Revision: 5.0 $")) + (string-match ":\\s *\\([0-9.]+\\)" v) + (substring v (match-beginning 1) (match-end 1))) + "Version of IZ-supported CPerl package this file is based on.") + +(provide 'cperl-mode) + +;;; cperl-mode.el ends here diff --git a/emacs_el/crontab-mode.el b/emacs_el/crontab-mode.el new file mode 100644 index 0000000..0f9ef22 --- /dev/null +++ b/emacs_el/crontab-mode.el @@ -0,0 +1,227 @@ +;;; 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 +;; 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 diff --git a/emacs_el/dna-mode.el b/emacs_el/dna-mode.el new file mode 100644 index 0000000..5433ea1 --- /dev/null +++ b/emacs_el/dna-mode.el @@ -0,0 +1,590 @@ +;;; 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 +;; 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 diff --git a/emacs_el/ecasound.el b/emacs_el/ecasound.el new file mode 100644 index 0000000..895ee0c --- /dev/null +++ b/emacs_el/ecasound.el @@ -0,0 +1,2321 @@ +;;; ecasound.el --- Interactive and programmatic interface to Ecasound + +;; Copyright (C) 2001, 2002 Mario Lang + +;; Author: Mario Lang +;; 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 + + +\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 + " +
+ +
+ +
+
\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

") + (let ((hits (cdar results))) + (while hits + (while (string-match "" (car hits)) + (setcar hits (replace-match "" t t (car hits)))) + (while (string-match (concat "\\([^*?[/>]\\)\\<\\(" term "\\)\\>") + (car hits)) + (setcar hits (replace-match "\\1\\2" + t nil (car hits)))) + (insert " > " (car hits) "\n") + (setq hits (cdr hits)))) + (insert "

\n\n")) + (setq results (cdr results))))) + +(defun emacs-wiki-setup-edit-page (page-name) + (insert "" emacs-wiki-http-edit-form "") + (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" + (buffer-string) "\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 "") + (insert "Thank you, your changes have been saved to " page) + (insert ". You will be redirected to " + "the new page in a moment.") + (insert "") + (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 "" emacs-wiki-http-search-form "") + (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 "
")
+	  (emacs-wiki-escape-html-specials)
+	  (goto-char (point-max))
+	  (if (re-search-backward "^Process.*killed" nil t)
+	      (delete-region (point) (point-max)))
+	  (insert "
") + (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 diff --git a/emacs_el/mode-compile.el b/emacs_el/mode-compile.el new file mode 100644 index 0000000..b83e1ba --- /dev/null +++ b/emacs_el/mode-compile.el @@ -0,0 +1,2648 @@ +;;; 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 +;; Maintainer: Heddy Boubaker +;; 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: +;; +;; +;; 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: +;; .(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 : +;; 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 +;; . 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 +;; .o file if no `main' function is +;; found inside or a 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 +;; "William A. Perkins" +;; Bin Mu +;; Gael MARZIOU +;; Christian Motschke +;; boris +;; Edward Hartnett . +;; Hartmut MANZ . +;; Henry Guillaume . +;; Ian Young +;; Ilya Zakharevich . +;; Kevin Broadey . +;; Lawrence R. Dodd . +;; Martin Jost . +;; Michael Welsh Duggan . +;; Rolf EBERT . +;; Scott Hofmann . +;; Stefan Schoef . +;; John W. Harwell - 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. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;; @ 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) + + +;; @@ 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) + + + +;; @@ 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) + + + +;; @@ 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) + + + +;; @@ 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++) + + + +;; @@ 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) + + + +;; @@ 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) + + + +;; @@ 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.") + + +;; @@ 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.") + + +;; @@ 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.") + + +;; @@ 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.") + + +;; @@ 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.") + + +;; @@ 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, 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.") + + +;; @@ 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) + + +;; @@ 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.") + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; @ 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)))))) + + +;; @ 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))))) + + +;; @ 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,"))) + + +;;;###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) + + +;;;###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) + + + +;;; Local variables: +;;; outline-regexp: ";; @+" +;;; eval: (outline-minor-mode 1) +;;; End: + +;;; mode-compile.el ends here diff --git a/emacs_el/mutt.el b/emacs_el/mutt.el new file mode 100644 index 0000000..2f3a39e --- /dev/null +++ b/emacs_el/mutt.el @@ -0,0 +1,396 @@ +;; mutt.el --- Use Emacs 20 as an external editor for the Mutt mailer +;; Copyright 1998 Eric Kidd + +;; Author: Eric Kidd +;; 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 . 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 ." + :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,\\| \\)" + "*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) diff --git a/emacs_el/post.el b/emacs_el/post.el new file mode 100644 index 0000000..6c1cade --- /dev/null +++ b/emacs_el/post.el @@ -0,0 +1,1397 @@ +; $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 , +;;; Dave Pearson , +;;; Rob Reid , +;;; Roland Rosenfeld + +;; 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 + +;;; 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 +;;; 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 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 . +;;; +;;; 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,\\| \\)" + "*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/#]" "") + "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 diff --git a/emacs_el/psvn.el b/emacs_el/psvn.el new file mode 100644 index 0000000..d057235 --- /dev/null +++ b/emacs_el/psvn.el @@ -0,0 +1,2273 @@ +;;; psvn.el --- Subversion interface for emacs +;; Copyright (C) 2002-2004 by Stefan Reichoer + +;; Author: Stefan Reichoer, +;; $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 ""); 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 "") 'svn-status-next-line) + (define-key svn-status-mode-map (kbd "") '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 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